102 lines
3.8 KiB
Haskell
102 lines
3.8 KiB
Haskell
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||
|
|
module SourceSyntax.Expression where
|
||
|
|
|
||
|
|
import Data.Data
|
||
|
|
import Data.List (intercalate)
|
||
|
|
import qualified Text.Pandoc as Pandoc
|
||
|
|
import qualified SourceSyntax.Helpers as Help
|
||
|
|
import qualified SourceSyntax.Location as Location
|
||
|
|
import qualified SourceSyntax.Pattern as Pattern
|
||
|
|
import qualified SourceSyntax.Literal as Literal
|
||
|
|
import Types.Types
|
||
|
|
|
||
|
|
type LExpr = Location.Located Expr
|
||
|
|
data Expr = Literal Literal.Literal
|
||
|
|
| Range LExpr LExpr
|
||
|
|
| Access LExpr String
|
||
|
|
| Remove LExpr String
|
||
|
|
| Insert LExpr String LExpr
|
||
|
|
| Modify LExpr [(String,LExpr)]
|
||
|
|
| Record [(String,[String],LExpr)]
|
||
|
|
| Binop String LExpr LExpr
|
||
|
|
| Lambda String LExpr
|
||
|
|
| App LExpr LExpr
|
||
|
|
| MultiIf [(LExpr,LExpr)]
|
||
|
|
| Let [Def] LExpr
|
||
|
|
| Var String
|
||
|
|
| Case LExpr [(Pattern.Pattern,LExpr)]
|
||
|
|
| Data String [LExpr]
|
||
|
|
| Markdown Pandoc.Pandoc
|
||
|
|
deriving (Eq, Data, Typeable)
|
||
|
|
|
||
|
|
data Def = FnDef String [String] LExpr
|
||
|
|
| OpDef String String String LExpr
|
||
|
|
| TypeAnnotation String Type
|
||
|
|
deriving (Eq, Data, Typeable)
|
||
|
|
|
||
|
|
cons h t = Location.merge h t (Data "Cons" [h,t])
|
||
|
|
nil = Location.L (Just "[]") Location.NoSpan (Data "Nil" [])
|
||
|
|
list = foldr cons nil
|
||
|
|
tuple es = Data ("Tuple" ++ show (length es)) es
|
||
|
|
|
||
|
|
delist (Location.L _ _ (Data "Cons" [h,t])) = h : delist t
|
||
|
|
delist _ = []
|
||
|
|
|
||
|
|
|
||
|
|
instance Show Expr where
|
||
|
|
show e =
|
||
|
|
let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in
|
||
|
|
case e of
|
||
|
|
Literal lit -> show lit
|
||
|
|
Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
|
||
|
|
Access e x -> show' e ++ "." ++ x
|
||
|
|
Remove e x -> Help.brkt (show e ++ " - " ++ x)
|
||
|
|
Insert (Location.L _ _ (Remove e y)) x v ->
|
||
|
|
Help.brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
|
||
|
|
Insert e x v -> Help.brkt (show e ++ " | " ++ x ++ " = " ++ show v)
|
||
|
|
Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
|
||
|
|
where field (x,e) = x ++ " <- " ++ show e
|
||
|
|
Record r -> Help.brkt (intercalate ", " (map fields r))
|
||
|
|
where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
|
||
|
|
Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
|
||
|
|
Lambda x e -> let (xs,e') = getLambdas (Location.none $ Lambda x e) in
|
||
|
|
concat [ "\\", intercalate " " xs, " -> ", show e' ]
|
||
|
|
App e1 e2 -> show' e1 ++ " " ++ show' e2
|
||
|
|
MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
|
||
|
|
where iff (b,e) = show b ++ " -> " ++ show e
|
||
|
|
sep = concatMap ("\n | " ++)
|
||
|
|
Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
|
||
|
|
Var (c:cs) -> if Help.isOp c then Help.parens (c:cs) else c:cs
|
||
|
|
Case e pats -> "case "++ show e ++" of " ++ Help.brkt (intercalate " ; " pats')
|
||
|
|
where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
|
||
|
|
Data name es
|
||
|
|
| name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
|
||
|
|
delist (Location.none $ Data "Cons" es)
|
||
|
|
| name == "Nil" -> "[]"
|
||
|
|
| otherwise -> name ++ " " ++ intercalate " " (map show' es)
|
||
|
|
Markdown _ -> "[markdown| ... |]"
|
||
|
|
|
||
|
|
|
||
|
|
instance Show Def where
|
||
|
|
show e =
|
||
|
|
case e of
|
||
|
|
FnDef v [] e -> v ++ " = " ++ show e
|
||
|
|
FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
|
||
|
|
OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
|
||
|
|
TypeAnnotation n t -> n ++ " : " ++ show t
|
||
|
|
|
||
|
|
getLambdas (Location.L _ _ (Lambda x e)) = (x:xs,e')
|
||
|
|
where (xs,e') = getLambdas e
|
||
|
|
getLambdas e = ([],e)
|
||
|
|
|
||
|
|
needsParens e =
|
||
|
|
case e of
|
||
|
|
Binop _ _ _ -> True
|
||
|
|
Lambda _ _ -> True
|
||
|
|
App _ _ -> True
|
||
|
|
MultiIf _ -> True
|
||
|
|
Let _ _ -> True
|
||
|
|
Case _ _ -> True
|
||
|
|
Data name (x:xs) -> name /= "Cons"
|
||
|
|
_ -> False
|