2013-06-03 07:44:45 +00:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
2012-04-19 06:32:10 +00:00
|
|
|
module Ast where
|
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
import Located
|
2013-04-04 08:09:35 +00:00
|
|
|
import Data.Char (isDigit, isSymbol)
|
2012-06-10 06:48:40 +00:00
|
|
|
import Data.List (intercalate)
|
2012-11-23 04:30:37 +00:00
|
|
|
import Types.Types
|
2012-09-02 05:26:35 +00:00
|
|
|
import qualified Text.Pandoc as Pandoc
|
2013-06-03 07:44:45 +00:00
|
|
|
import Data.Data
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2013-06-06 09:27:20 +00:00
|
|
|
data Module = Module [String] Exports Imports [Statement] deriving (Show)
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
type Exports = [String]
|
|
|
|
|
2012-06-12 06:28:45 +00:00
|
|
|
type Imports = [(String, ImportMethod)]
|
2013-04-03 07:32:21 +00:00
|
|
|
data ImportMethod = As String | Importing [String] | Hiding [String]
|
2013-06-03 07:44:45 +00:00
|
|
|
deriving (Eq, Ord, Show, Data, Typeable)
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-06-10 06:48:40 +00:00
|
|
|
|
2012-12-26 22:07:09 +00:00
|
|
|
data Pattern = PData String [Pattern]
|
|
|
|
| PRecord [String]
|
2013-06-07 00:53:50 +00:00
|
|
|
| PAsVar String Pattern
|
2012-12-26 22:07:09 +00:00
|
|
|
| PVar String
|
|
|
|
| PAnything
|
2013-06-03 07:44:45 +00:00
|
|
|
deriving (Eq, Data, Typeable)
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
type CExpr = Located Expr
|
2012-07-19 11:47:53 +00:00
|
|
|
data Expr = IntNum Int
|
|
|
|
| FloatNum Float
|
2012-04-19 06:32:10 +00:00
|
|
|
| Chr Char
|
2012-05-20 05:11:45 +00:00
|
|
|
| Str String
|
2012-04-19 06:32:10 +00:00
|
|
|
| Boolean Bool
|
2012-12-25 08:39:18 +00:00
|
|
|
| Range CExpr CExpr
|
|
|
|
| Access CExpr String
|
2012-12-26 22:07:09 +00:00
|
|
|
| Remove CExpr String
|
|
|
|
| Insert CExpr String CExpr
|
|
|
|
| Modify CExpr [(String,CExpr)]
|
2012-12-25 08:39:18 +00:00
|
|
|
| Record [(String,[String],CExpr)]
|
|
|
|
| Binop String CExpr CExpr
|
|
|
|
| Lambda String CExpr
|
|
|
|
| App CExpr CExpr
|
|
|
|
| If CExpr CExpr CExpr
|
|
|
|
| MultiIf [(CExpr,CExpr)]
|
|
|
|
| Let [Def] CExpr
|
2012-04-19 06:32:10 +00:00
|
|
|
| Var String
|
2012-12-25 08:39:18 +00:00
|
|
|
| Case CExpr [(Pattern,CExpr)]
|
|
|
|
| Data String [CExpr]
|
2012-09-02 05:26:35 +00:00
|
|
|
| Markdown Pandoc.Pandoc
|
2013-06-03 07:44:45 +00:00
|
|
|
deriving (Eq, Data, Typeable)
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
data Def = FnDef String [String] CExpr
|
|
|
|
| OpDef String String String CExpr
|
2013-06-03 07:44:45 +00:00
|
|
|
| TypeAnnotation String Type
|
|
|
|
deriving (Eq, Data, Typeable)
|
2012-07-21 23:48:51 +00:00
|
|
|
|
2012-11-23 03:48:54 +00:00
|
|
|
data Statement = Definition Def
|
2012-08-01 23:37:37 +00:00
|
|
|
| Datatype String [X] [(String,[Type])]
|
2013-02-06 11:04:55 +00:00
|
|
|
| TypeAlias String [X] Type
|
2012-12-25 08:39:18 +00:00
|
|
|
| ImportEvent String CExpr String Type
|
2012-08-01 23:37:37 +00:00
|
|
|
| ExportEvent String String Type
|
2013-06-03 07:44:45 +00:00
|
|
|
deriving (Eq, Show, Data, Typeable)
|
2012-08-01 23:37:37 +00:00
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
cons h t = epos h t (Data "Cons" [h,t])
|
2013-05-29 23:20:38 +00:00
|
|
|
nil = L (Just "[]") NoSpan (Data "Nil" [])
|
2012-04-19 06:32:10 +00:00
|
|
|
list = foldr cons nil
|
|
|
|
tuple es = Data ("Tuple" ++ show (length es)) es
|
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
delist (L _ _ (Data "Cons" [h,t])) = h : delist t
|
2012-04-19 06:32:10 +00:00
|
|
|
delist _ = []
|
|
|
|
|
|
|
|
|
|
|
|
pcons h t = PData "Cons" [h,t]
|
|
|
|
pnil = PData "Nil" []
|
|
|
|
plist = foldr pcons pnil
|
|
|
|
ptuple es = PData ("Tuple" ++ show (length es)) es
|
2012-06-10 06:48:40 +00:00
|
|
|
|
2012-12-26 22:07:09 +00:00
|
|
|
brkt s = "{ " ++ s ++ " }"
|
2013-03-14 08:04:51 +00:00
|
|
|
parensIf b s = if b then parens s else s
|
2013-04-04 08:09:35 +00:00
|
|
|
isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
|
2012-12-26 22:07:09 +00:00
|
|
|
|
2012-06-10 06:48:40 +00:00
|
|
|
instance Show Pattern where
|
2013-03-14 08:04:51 +00:00
|
|
|
show p =
|
|
|
|
case p of
|
|
|
|
PRecord fs -> brkt (intercalate ", " fs)
|
|
|
|
PVar x -> x
|
2013-06-07 00:53:50 +00:00
|
|
|
PAsVar x p -> x ++ "@(" ++ show p ++ ")"
|
2013-03-14 08:04:51 +00:00
|
|
|
PAnything -> "_"
|
|
|
|
PData "Cons" [hd@(PData "Cons" _),tl] ->
|
|
|
|
parens (show hd) ++ " :: " ++ show tl
|
|
|
|
PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
|
|
|
|
PData "Nil" [] -> "[]"
|
|
|
|
PData name ps ->
|
2012-06-10 06:48:40 +00:00
|
|
|
if take 5 name == "Tuple" && all isDigit (drop 5 name) then
|
|
|
|
parens . intercalate ", " $ map show ps
|
2013-03-14 08:04:51 +00:00
|
|
|
else parensIf (not (null ps)) $ unwords (name : map show ps)
|
2012-07-28 18:34:47 +00:00
|
|
|
|
|
|
|
instance Show Expr where
|
2012-12-25 08:39:18 +00:00
|
|
|
show e =
|
2013-05-29 23:20:38 +00:00
|
|
|
let show' (L _ _ e) = parensIf (needsParens e) (show e) in
|
2012-12-25 08:39:18 +00:00
|
|
|
case e of
|
|
|
|
IntNum n -> show n
|
|
|
|
FloatNum n -> show n
|
|
|
|
Chr c -> show c
|
|
|
|
Str s -> show s
|
|
|
|
Boolean b -> show b
|
|
|
|
Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
|
|
|
|
Access e x -> show' e ++ "." ++ x
|
2012-12-26 22:07:09 +00:00
|
|
|
Remove e x -> brkt (show e ++ " - " ++ x)
|
2013-05-29 23:20:38 +00:00
|
|
|
Insert (L _ _ (Remove e y)) x v ->
|
2012-12-26 22:07:09 +00:00
|
|
|
brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
|
|
|
|
Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
|
|
|
|
Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
|
|
|
|
where field (x,e) = x ++ " <- " ++ show e
|
|
|
|
Record r -> brkt (intercalate ", " (map fields r))
|
2012-12-25 08:39:18 +00:00
|
|
|
where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
|
|
|
|
Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
|
2013-05-29 23:20:38 +00:00
|
|
|
Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in
|
2012-07-28 18:34:47 +00:00
|
|
|
concat [ "\\", intercalate " " xs, " -> ", show e' ]
|
2012-12-25 08:39:18 +00:00
|
|
|
App e1 e2 -> show' e1 ++ " " ++ show' e2
|
|
|
|
If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
|
|
|
|
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
|
2013-04-04 08:09:35 +00:00
|
|
|
Var (c:cs) -> if isOp c then parens (c:cs) else c:cs
|
2012-12-26 22:07:09 +00:00
|
|
|
Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
|
2012-12-25 08:39:18 +00:00
|
|
|
where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
|
|
|
|
Data name es
|
|
|
|
| name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
|
2013-05-29 23:20:38 +00:00
|
|
|
delist (notLocated $ Data "Cons" es)
|
2012-12-25 08:39:18 +00:00
|
|
|
| name == "Nil" -> "[]"
|
|
|
|
| otherwise -> name ++ " " ++ intercalate " " (map show' es)
|
|
|
|
Markdown _ -> "[markdown| ... |]"
|
2012-07-28 18:34:47 +00:00
|
|
|
|
2012-08-09 14:38:18 +00:00
|
|
|
|
2012-11-23 03:48:54 +00:00
|
|
|
instance Show Def where
|
2012-12-25 08:39:18 +00:00
|
|
|
show e =
|
|
|
|
case e of
|
|
|
|
FnDef v [] e -> v ++ " = " ++ show e
|
2013-05-29 23:20:38 +00:00
|
|
|
FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
|
2012-12-25 08:39:18 +00:00
|
|
|
OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
|
2013-06-03 07:44:45 +00:00
|
|
|
TypeAnnotation n t -> n ++ " : " ++ show t
|
2012-07-28 18:34:47 +00:00
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
|
2012-07-28 18:34:47 +00:00
|
|
|
where (xs,e') = getLambdas e
|
|
|
|
getLambdas e = ([],e)
|
|
|
|
|
2013-03-14 08:04:51 +00:00
|
|
|
needsParens e =
|
|
|
|
case e of
|
|
|
|
Binop _ _ _ -> True
|
|
|
|
Lambda _ _ -> True
|
|
|
|
App _ _ -> True
|
|
|
|
If _ _ _ -> True
|
|
|
|
Let _ _ -> True
|
|
|
|
Case _ _ -> True
|
|
|
|
Data name (x:xs) -> name /= "Cons"
|
|
|
|
_ -> False
|