<commit_before>{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, DeriveDataTypeable, StandaloneDeriving #-}
module PTS.Syntax.Term
  ( Term (..)
  , TypedTerm (..)
  , TermStructure (..)
  , Structure (structure)
  , structure'
  , typeOf
  , mkInt
  , mkIntOp
  , mkIfZero
  , mkVar
  , mkConst
  , mkApp
  , mkLam
  , mkPi
  , mkPos
  , mkUnquote
  , mkInfer
  , freshvarl
  , handlePos
  , typedHandlePos
  , evalOp
  , BinOp (..)
  , desugarArgs
  ) where

import Control.Applicative ((<$>))

import Data.Data (Data)
import Data.Typeable (Typeable)

import PTS.Error
import PTS.Syntax.Constants (C(C))
import PTS.Syntax.Names (Name, Names, freshvarl)


-- Syntax

-- the string in IntOp is an identifier for the function. It is necessary
-- to check equivalence of terms (the functions cannot be directly compared)

-- type Tag = Int

data Term = MkTerm (TermStructure Term)
  deriving (Data, Typeable, Show)

data TypedTerm = MkTypedTerm (TermStructure TypedTerm) TypedTerm
  deriving (Data, Typeable)

instance Show TypedTerm where
  showsPrec d t @ (MkTypedTerm struct typ) =
    showParen (d > app_prec) $
      showString "MkTypedTerm " . showsPrec (app_prec + 1) struct .
        if (loops t)
         then showString " <self>" -- This is the only non-default behavior.
         else showString " " . showsPrec (app_prec + 1) typ
   where
     app_prec = 10

loops t1 = sameConst (structure' t1) (structure' (typeOf t1))
 where
   sameConst (Const (C c1)) (Const (C c2)) = c1 == c2
   sameConst _ _ = False

class Structure term where
  structure :: term -> TermStructure term

instance Structure Term where
  structure (MkTerm t) = t

instance Structure TypedTerm where
  structure (MkTypedTerm t _) = t

-- | Return the actual TermStructure of a Term-like thing without Pos nodes.
structure' :: Structure term => term -> TermStructure term
structure' t = case structure t of
  Pos _ t -> structure' t
  t -> t

typeOf :: TypedTerm -> TypedTerm
typeOf (MkTypedTerm _ t) = t

data BinOp
  = Add
  | Sub
  | Mul
  | Div
  deriving (Eq, Data, Typeable, Show)

returnLift2 :: (a -> b -> c) -> a -> b -> Maybe c
returnLift2 = ((Just .) .)

evalOp :: BinOp -> (Integer -> Integer -> Maybe Integer)
evalOp Add = returnLift2 (+)
evalOp Sub = returnLift2 (-)
evalOp Mul = returnLift2 (*)
evalOp Div = safeDiv
  where
    safeDiv x 0 = Nothing
    safeDiv x y = Just $ div x y

data TermStructure alpha
  = Int     Integer
  | IntOp   Name BinOp alpha alpha
  | IfZero  alpha alpha alpha
  | Var     Name
  | Const   C<commit_msg>Move comment and tag it as outdated<commit_after>{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, DeriveDataTypeable, StandaloneDeriving #-}
module PTS.Syntax.Term
  ( Term (..)
  , TypedTerm (..)
  , TermStructure (..)
  , Structure (structure)
  , structure'
  , typeOf
  , mkInt
  , mkIntOp
  , mkIfZero
  , mkVar
  , mkConst
  , mkApp
  , mkLam
  , mkPi
  , mkPos
  , mkUnquote
  , mkInfer
  , freshvarl
  , handlePos
  , typedHandlePos
  , evalOp
  , BinOp (..)
  , desugarArgs
  ) where

import Control.Applicative ((<$>))

import Data.Data (Data)
import Data.Typeable (Typeable)

import PTS.Error
import PTS.Syntax.Constants (C(C))
import PTS.Syntax.Names (Name, Names, freshvarl)


-- Syntax

data Term = MkTerm (TermStructure Term)
  deriving (Data, Typeable, Show)

data TypedTerm = MkTypedTerm (TermStructure TypedTerm) TypedTerm
  deriving (Data, Typeable)

instance Show TypedTerm where
  showsPrec d t @ (MkTypedTerm struct typ) =
    showParen (d > app_prec) $
      showString "MkTypedTerm " . showsPrec (app_prec + 1) struct .
        if (loops t)
         then showString " <self>" -- This is the only non-default behavior.
         else showString " " . showsPrec (app_prec + 1) typ
   where
     app_prec = 10

loops t1 = sameConst (structure' t1) (structure' (typeOf t1))
 where
   sameConst (Const (C c1)) (Const (C c2)) = c1 == c2
   sameConst _ _ = False

class Structure term where
  structure :: term -> TermStructure term

instance Structure Term where
  structure (MkTerm t) = t

instance Structure TypedTerm where
  structure (MkTypedTerm t _) = t

-- | Return the actual TermStructure of a Term-like thing without Pos nodes.
structure' :: Structure term => term -> TermStructure term
structure' t = case structure t of
  Pos _ t -> structure' t
  t -> t

typeOf :: TypedTerm -> TypedTerm
typeOf (MkTypedTerm _ t) = t

data BinOp
  = Add
  | Sub
  | Mul
  | Div
  deriving (Eq, Data, Typeable, Show)

returnLift2 :: (a -> b -> c) -> a -> b -> Maybe c
returnLift2 = ((Just .) .)

evalOp :: BinOp -> (Integer -> Integer -> Maybe Integer)
evalOp Add = returnLift2 (+)
evalOp Sub = returnLift2 (-)
evalOp Mul = returnLift2 (*)
evalOp Div = safeDiv
  where
    safeDiv x 0 = Nothing
    safeDiv x y = Just $ div x y

-- XXX outdated.

-- the string in IntOp is an identifier for the function. It is necessary
-- to check equivalence of terms (the functions cannot be directly compared)

data TermStructure alpha
  = Int     Integer
  | IntOp   Name BinOp alpha alpha
  | IfZero  alpha alpha alpha
  | Var     Name
  | Const   C
{'fraction_non_alphanumeric': 0.10170822697820538, 'fraction_numerical': 0.006675829569998037, 'mean_word_length': 3.0428571428571427, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 37, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1652748', 'n_tokens_mistral': 1746, 'n_tokens_neox': 1717, 'n_words': 578}