├── .gitignore ├── .sugar.lp.swp ├── AST ├── Ast_tests.hs ├── DataTypes.hs ├── Environment.hs └── Interpreter.hs ├── Converter.hs ├── Lollipop_project_poster.pdf ├── Lollipop_publish.pdf ├── README.md ├── TI.hs ├── TypeTest.hs ├── grammar ├── grammar.cf └── testProgram.lp ├── logo.png ├── loli.hs ├── sugar.lp ├── testLinear.lp ├── testList.lp └── testProgram.lp /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | *.bak 17 | Makefile 18 | *.y 19 | *.x 20 | -------------------------------------------------------------------------------- /.sugar.lp.swp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/m0ar/lollipop/fffaf13b831b819b8e8a309468147874a8097727/.sugar.lp.swp -------------------------------------------------------------------------------- /AST/Ast_tests.hs: -------------------------------------------------------------------------------- 1 | module AST.Ast_tests where 2 | 3 | import AST.Interpreter 4 | import AST.Environment 5 | import AST.DataTypes 6 | import Test.QuickCheck 7 | 8 | main = do 9 | t1 <- testHello 10 | t2 <- testLetIn 11 | t3 <- testLazyLetIn 12 | -- t4 <- testEConstr 13 | --t5 <- testCase 14 | --t6 <- testSumList list4 15 | --t7 <- testSumList2 16 | t8 <- testLam 17 | t9 <- testFuncs 18 | t10 <- testFuncs2 19 | t11 <- testBinOps 20 | t12 <- testLazyFuncs 21 | t13 <- testThen 22 | 23 | return (t1 24 | ,t2 25 | ,t3 26 | -- ,t4 27 | -- ,t5 28 | --,t6 29 | --,t7 30 | ,t8 31 | ,t9 32 | ,t10 33 | ,t11 34 | ,t12 35 | ,t13 36 | ) 37 | 38 | 39 | -------------------------------------------------------------------------------- 40 | -- things to use in tests 41 | -------------------------------------------------------------------------------- 42 | dCon = DConstr "Cons" (VFun (\v1 -> VFun (\v2 -> VConstr "Cons" [v1,v2]))) 43 | dNil = DConstr "Nil" (VConstr "Nil" []) 44 | 45 | eZero = ELit (ILit 0) 46 | eOne = ELit (ILit 1) 47 | eTwo = ELit (ILit 2) 48 | eThree = ELit (ILit 3) 49 | eFour = ELit (ILit 4) 50 | eFive = ELit (ILit 5) 51 | eSix = ELit (ILit 6) 52 | eSeven = ELit (ILit 7) 53 | eEight = ELit (ILit 8) 54 | eNine = ELit (ILit 9) 55 | x = EVar "x" 56 | y = EVar "x" 57 | z = EVar "x" 58 | 59 | -- Cons 5 Nil -> [5] 60 | list1 = (EApp (EApp (EConstr "Cons") (eFive)) (EConstr "Nil")) 61 | 62 | -- Cons 5 (Cons 2 Nil) -> [5,2] 63 | list2 = (EApp 64 | (EApp (EConstr "Cons") (eFive)) 65 | (EApp (EApp (EConstr "Cons") (eTwo)) (EConstr "Nil")) 66 | ) 67 | 68 | -- Cons 5 (Cons 2 (Cons 3 Nil)) -> [5,2,3] 69 | list3 = (EApp 70 | (EApp (EConstr "Cons") (eFive)) 71 | (EApp (EApp (EConstr "Cons") (eTwo)) 72 | (EApp (EApp (EConstr "Cons") (eThree)) (EConstr "Nil"))) 73 | ) 74 | 75 | -- Cons 5 (Cons 2 (Cons 3 (Cons 1))) -> [5,2,3,1] 76 | list4 = (EApp 77 | (EApp (EConstr "Cons") (eFive)) 78 | (EApp (EApp (EConstr "Cons") (eTwo)) 79 | (EApp (EApp (EConstr "Cons") (eThree)) 80 | (EApp (EApp (EConstr "Cons") (eOne)) (EConstr "Nil")))) 81 | ) 82 | 83 | -------------------------------------------------------------------------------- 84 | -- tests 85 | -------------------------------------------------------------------------------- 86 | {- 87 | main = print "HejsaN" 88 | -} 89 | testHello = interpret helloMain -- hello world 90 | where 91 | helloMain = [(DFunc "main" [] (EApp 92 | (EVar "print") 93 | (ELit (SLit "HejsaN"))))] 94 | {- 95 | Testing of user input. 96 | -} 97 | testReadLine = interpret readLine 98 | where 99 | readLine = [(DFunc "main" [] (EVar "readLine"))] 100 | 101 | {- 102 | Testing of cLiting a user input. The input funcs result is passed to the print function. 103 | -} 104 | testBind = interpret bind 105 | where 106 | bind = [(DFunc "main" [] bind')] 107 | bind' = EApp (EApp (EVar "bind") (EVar "readLine")) (EVar "print") 108 | 109 | testThen = interpret thenF 110 | where 111 | thenF = [(DFunc "main" [] thenF')] 112 | thenF' = EApp (EApp (EVar "then") (EApp (EVar "print") (ELit (SLit "Hello")))) (EApp (EVar "print") (ELit (SLit "Jonas"))) 113 | 114 | 115 | {- 116 | main = let x = 5 + 9 in x + 3 117 | -} 118 | testLetIn = interpret letInMain 119 | where 120 | let' = ELetIn "x" (EBinOp Add eFive eNine) (EBinOp Add (EVar "x") eThree) 121 | letInMain = [DFunc "main" [] let'] 122 | 123 | {- 124 | main = let x = x+1 in 5 125 | -} 126 | testLazyLetIn = interpret lazyLetInMain 127 | where 128 | let' = ELetIn "x" (EBinOp Add (EVar "x") eOne) eFive 129 | lazyLetInMain = [DFunc "main" [] let'] 130 | 131 | {- 132 | main = Cons 5 Nil 133 | -} 134 | testEConstr = interpret [econMain,dCon,dNil] 135 | where 136 | econMain = DFunc "main" [] (EApp (EApp (EConstr "Cons") (eFive)) (EConstr "Nil")) 137 | 138 | {-- testCase = interpret caseMain 139 | where elist = list1 140 | -- elist = EConstr "Nil" [] 141 | p1 = PConstr "Cons" ["x", "xs"] 142 | e1 = EBinOp Add (EVar "x") eZero 143 | p2 = PConstr "Nil" [] 144 | ecase = ECase elist [(p1,e1), (p2,eZero)] 145 | caseMain = [(DFunc "main" [] ecase), dCon, dNil] 146 | 147 | testCase1 = interpret caseMain 148 | where caseMain = [(DFunc "main" ["x"] ecase)] 149 | ecase = ECase (EVar "x") [(p,e)] 150 | p = PConstr "main" [] 151 | e = ELit (ILit 2) --} 152 | 153 | {-- testSumList :: Exp -> IO () 154 | testSumList l = interpret [dMain, dSum, dCon, dNil] 155 | where dMain = DFunc "main" [] (EApp (EVar "sum") l) 156 | p1 = PConstr "Cons" ["x", "xs2"] 157 | e1 = EBinOp Add (EVar "x") 158 | (EApp (EVar "sum") (EVar "xs2")) 159 | p2 = PConstr "Nil" [] 160 | ecase = ECase (EVar "xs") [(p1, e1), (p2, eZero)] 161 | dSum = DFunc "sum" ["xs"] ecase --} 162 | 163 | testPattern1 = interpret [(DFunc "main" [] lam)] 164 | where p1 = PLit (ILit 5) 165 | e1 = EApp (EVar "print") (ELit (SLit "First case")) 166 | p2 = PWild 167 | e2 = EApp (EVar "print") (ELit (SLit "Second case")) 168 | lam = EApp (ELam "x" (ECase x [(p1,e1),(p2,e2)])) eZero 169 | 170 | 171 | {-- testSumList2 = interpret [dMain, dSum, dCon, dNil] 172 | where 173 | dMain = DFunc "main" [] (EApp (EVar "sum") list1) 174 | dSum = DFunc "sum" ["xs"] (ECase (EVar "xs") [(p1, eZero), (p2, e2)]) 175 | where 176 | p1 = PConstr "Nil" [] 177 | p2 = PConstr "Cons" ["x", "xs'"] 178 | e2 = EBinOp Add (EVar "x") (EApp (EVar "sum") (EVar "xs'")) 179 | --} 180 | {- 181 | main = (\x -> x + 4) ((\x -> x + 4) 6) -- should return 14 182 | -} 183 | testLam = interpret lamMain -- lambda-calculus addition with application 184 | where lam = EApp (ELam "x" (EBinOp Add (EVar "x") eFour)) 185 | (EApp (ELam "x" (EBinOp Add (EVar "x") 186 | eFour)) eSix) 187 | lamMain = [(DFunc "main" [] lam)] 188 | 189 | {- 190 | main = add 5 2 191 | add x y = x + y 192 | -} 193 | testFuncs = interpret funcMain 194 | where funcMain = [ 195 | (DFunc "main" [] (EApp (EApp (EVar "adds") 196 | eFive) eTwo)), 197 | (DFunc "adds" ["x","y"] (EBinOp Add (EVar "x") (EVar "y"))) 198 | ] 199 | {- 200 | main = add 3 201 | add x = x + 2 202 | -} 203 | testFuncs2 = interpret funcMain 204 | where funcMain = [ 205 | (DFunc "main" [] (EApp (EVar "add") eThree)), 206 | (DFunc "add" ["x"] (EBinOp Add (EVar "x") eTwo)) 207 | ] 208 | 209 | {- 210 | main = 2 + 3 211 | -} 212 | testAdd = interpret addMain 213 | where addMain = [(DFunc "main" [] (EBinOp Add (ELit (ILit 2)) (ELit (ILit 3))))] 214 | 215 | {- 216 | main = 2+3*4 217 | -} 218 | testBinOps = interpret $ [DFunc "main" [] 219 | (EApp (EApp (EVar "#add") eTwo) 220 | (EApp (EApp (EVar "#mul") eThree) eFour))] 221 | 222 | {- 223 | main = first 5 (infty 0) 224 | first x y = x 225 | infty x = 1 + infty x 226 | -} 227 | testLazyFuncs = interpret [funcMain, funcFirst, funcInfty] where 228 | funcMain = DFunc "main" [] (EApp (EApp (EVar "first") eFive) (EApp (EVar "infty") eZero)) 229 | funcFirst = DFunc "first" ["x", "y"] (EVar "x") 230 | funcInfty = DFunc "infty" ["x"] (EBinOp Add eOne (EApp (EVar "infty") (EVar "x"))) 231 | -------------------------------------------------------------------------------- /AST/DataTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module AST.DataTypes where 3 | 4 | import ErrM 5 | import Control.Exception 6 | import Data.Typeable 7 | import qualified Text.PrettyPrint as PP 8 | 9 | data LoliException = NoSuchFile | SyntaxError | LinearException String 10 | | TypeException String | Undefined String 11 | deriving (Show, Typeable) 12 | instance Exception LoliException 13 | 14 | data Program = Program [DataDecl] [FuncDecl] 15 | deriving (Show) 16 | 17 | data FuncDecl = DFunc Var Type Vars Exp 18 | deriving (Show) 19 | 20 | data DataDecl = DData ConstrID [Var] [ConstrDecl] 21 | deriving (Show) 22 | 23 | data ConstrDecl = ConstrDecl ConstrID [Type] 24 | deriving (Show) 25 | 26 | data Scheme = Scheme [Var] Type 27 | 28 | 29 | data Exp = EApp Exp Exp 30 | | EVar Var 31 | | ELit Lit 32 | | EUnOp Op Exp 33 | | EBinOp Op Exp Exp 34 | | ELam Var Exp 35 | | EConstr ConstrID 36 | | ECase Exp [(Pattern, Exp)] 37 | | ELetIn Var Exp Exp -- let var = exp in exp 38 | | EListComp Exp [(Var, Value)] Exp 39 | 40 | data Op = Cons | Concat | Add | Sub | Mul | Div 41 | | Gt | Eq | Or | Not | Pow | Bind | Then 42 | 43 | data Pattern = PConstr ConstrID [Pattern] 44 | | PLit Lit 45 | | PWild 46 | | PVar Var 47 | 48 | type Var = String 49 | 50 | -- A list of variables to be used in function bodies 51 | type Vars = [Var] 52 | 53 | data Value = VIO (IO Value) -- void IO 54 | | VLit Lit 55 | | VConstr ConstrID [Value] -- list of values to be used as parameters 56 | | VFun (Value -> Value) 57 | 58 | type ConstrID = String 59 | 60 | data Lit = ILit Int 61 | | DLit Double 62 | | CLit Char 63 | deriving Eq 64 | 65 | instance Eq Value where 66 | (==) (VLit (ILit x)) (VLit (ILit y)) = x == y 67 | (==) (VLit (DLit x)) (VLit (DLit y)) = x == y 68 | (==) (VLit (CLit x)) (VLit (CLit y)) = x == y 69 | (==) _ _ = False 70 | 71 | instance Num Lit where 72 | (+) (ILit x) (ILit y) = ILit (x+y) 73 | (+) (DLit x) (DLit y) = DLit (x+y) 74 | (+) (ILit x) (DLit y) = DLit ((fromIntegral x)+y) 75 | (+) (DLit x) (ILit y) = DLit (x+(fromIntegral y)) 76 | (*) (ILit x) (ILit y) = ILit (x*y) 77 | (*) (DLit x) (DLit y) = DLit (x*y) 78 | (*) (ILit x) (DLit y) = DLit ((fromIntegral x)*y) 79 | (*) (DLit x) (ILit y) = DLit (x*(fromIntegral y)) 80 | 81 | instance Show Op where 82 | show op = case op of 83 | Concat -> "#concat" 84 | Cons -> "#cons" 85 | Gt -> "#gt" 86 | Eq -> "#eq" 87 | Not -> "#not" 88 | Or -> "#or" 89 | Add -> "#add" 90 | Mul -> "#mul" 91 | Pow -> "#pow" 92 | Div -> "#div" 93 | Bind -> "#bind" 94 | Then -> "#then" 95 | 96 | instance Show Lit where 97 | show lit = case lit of 98 | ILit i -> show i 99 | DLit d -> show d 100 | CLit c -> [c] 101 | 102 | --instance Show Declaration where 103 | -- show (DFunc var tDecls vars e) = "function: " ++ var ++ "\n " ++ (show e) 104 | 105 | -- Show functions -- 106 | instance Show Exp where 107 | show e = case e of 108 | EApp e1 e2 -> show e1 ++ " " ++ show e2 109 | EVar s -> s 110 | ELit l -> show l 111 | EConstr cid -> show cid 112 | EUnOp op e -> case op of 113 | Not -> "!" ++ show e 114 | _ -> "Unary operator: '" ++ show op ++ "'" 115 | EBinOp op e1 e2 -> case op of 116 | Add -> disp "+" 117 | Sub -> disp "-" 118 | Mul -> disp "*" 119 | Div -> disp "/" 120 | Bind -> disp "<-" 121 | Then -> disp ">>" 122 | Gt -> disp ">" 123 | Eq -> disp "==" 124 | Or -> disp "||" 125 | Pow -> disp "^" 126 | _ -> show e1 ++ " binary operator: '" ++ show op ++ "' " ++ show e2 127 | where 128 | disp op = show e1 ++ " " ++ op ++ " " ++ show e2 129 | ELam v e -> "\\" ++ v ++ " -> " ++ show e 130 | ECase e ps -> "case " ++ show e ++ " of \n" ++ (concatMap show ps) 131 | ELetIn v e1 e2 -> "let " ++ v ++ " = " ++ show e1 ++ " in \n " ++ show e2 132 | 133 | instance Show Pattern where 134 | show p = case p of 135 | PConstr cid vs -> " " ++ cid ++ " " ++ (concatMap show vs) 136 | PLit l -> show l 137 | PWild -> "_ -> " 138 | PVar v -> v ++ " -> " 139 | 140 | instance Show Value where 141 | show v = case v of 142 | (VLit lit) -> show lit 143 | (VIO v) -> "IO!!!!" 144 | (VFun f) -> "gotta function" 145 | (VConstr cid vs) -> case cid of 146 | "(,)" -> "(" ++ (show (vs !! 0)) ++ ", " ++ (show (vs !! 1)) ++ ")" 147 | "(,,)" -> "(" ++ (show (vs !! 0)) ++ ", " ++ (show (vs !! 1)) ++ ", " ++ (show (vs !! 2)) ++ ")" 148 | "Nil" -> "[]" 149 | "Cons" -> "[" ++ (AST.DataTypes.showList vs) ++ "]" 150 | _ -> cid ++ " " ++ concat (Prelude.map show vs) 151 | 152 | instance Show Scheme where 153 | show (Scheme vs t) = show t 154 | 155 | showList :: [Value] -> String 156 | showList [v, (VConstr "Nil" [])] = show v 157 | showList [v, (VConstr "Cons" vs)] = (show v) ++ ", " ++ AST.DataTypes.showList vs 158 | 159 | -- Types 160 | data Type = 161 | TVar Var 162 | | TiVar Var 163 | | TConstr ConstrID 164 | | TiConstr ConstrID 165 | | TFun Type Type 166 | | TApp Type Type 167 | deriving (Eq) 168 | 169 | instance Show Type where 170 | showsPrec _ x = shows (prType x) 171 | 172 | prType :: Type -> PP.Doc 173 | prType (TVar n) = PP.text n 174 | prType (TiVar n) = PP.text "Linear" PP.<+> PP.text n 175 | prType (TConstr s) = PP.text s 176 | prType (TiConstr s)= PP.text "Linear" PP.<+> PP.text s 177 | prType (TFun t s) = prParenType t PP.<+> PP.text "->" PP.<+> prType s 178 | prType (TApp t s) = prParenType t PP.<+> prType s 179 | 180 | 181 | 182 | prParenType :: Type -> PP.Doc 183 | prParenType t = case t of 184 | TFun _ _ -> PP.parens (prType t) 185 | _ -> prType t 186 | -------------------------------------------------------------------------------- /AST/Environment.hs: -------------------------------------------------------------------------------- 1 | module AST.Environment where 2 | 3 | import Data.Map 4 | import qualified Data.Map as M 5 | import AST.DataTypes 6 | import Control.Exception 7 | 8 | type Env = Map Var Value 9 | 10 | 11 | -- Adds a variable, value mapping to environment 12 | addToEnv :: Env -> Var -> Value -> Env 13 | addToEnv env var val = M.insert var val env 14 | 15 | -- Adds many variable, value mappings to environment. 16 | -- Used in case and pattern matching 17 | addManyToEnv :: Env -> [Var] -> [Value] -> Env 18 | addManyToEnv env [] [] = env 19 | addManyToEnv env [] _ = error "variables and values not same length" 20 | addManyToEnv env _ [] = error "variables and values not same length" 21 | addManyToEnv env (v1:vars) (v2:vals) = addManyToEnv (addToEnv env v1 v2) vars vals 22 | 23 | lookupInEnv :: Env -> Var -> Value 24 | lookupInEnv env var = case M.lookup var env of 25 | Nothing -> throw $ Undefined $ "Internal error: Not found in environment: " ++ var 26 | Just v -> v 27 | 28 | -- consumes, and unbinds a linear variable 29 | -- once used the name of the variable starts 30 | -- with an ! 31 | consumeLinear :: Env -> Var -> Env 32 | consumeLinear e v = M.insert ("!" ++ v) (VConstr "" []) e' 33 | where e' = M.delete v e 34 | 35 | startEnvironment :: [(String, Value, Scheme)] 36 | startEnvironment = [ 37 | ( "printChar" 38 | ,VFun $ \(VLit (CLit cs)) -> VIO $ vPrint cs 39 | ,Scheme [] $ TFun (TConstr "Char") 40 | (TApp (TConstr "IO") (TConstr "Char")) 41 | ), 42 | 43 | ( "readLine" 44 | ,VIO $ fmap strToValue readLn 45 | ,Scheme [] $ TApp (TConstr "IO") (TApp (TConstr "[]") (TConstr "Char")) 46 | ), 47 | 48 | ( "undefined" 49 | ,throw (Undefined "undefined") 50 | ,Scheme ["a"] a 51 | ), 52 | ( "#concat" 53 | ,VFun $ \v1 -> VFun $ \v2 -> vConcat v1 v2 54 | ,Scheme ["a"] $ TFun (TApp (TConstr "[]") a) (TFun (TApp (TConstr "[]") a) (TApp (TConstr "[]") a)) 55 | ), 56 | ( "#cons" 57 | ,VFun $ \v -> VFun $ \(VConstr cid vs) -> (VConstr "Cons" [v, (VConstr cid vs)]) 58 | ,Scheme ["a","b"] $ TFun a (TFun b (TApp (TConstr "[]") a)) 59 | ), 60 | ( "#add" 61 | ,VFun $ \(VLit x) -> VFun $ \(VLit y) -> VLit $ x+y 62 | ,Scheme [] $ TFun (TConstr "Int") 63 | (TFun (TConstr "Int") 64 | (TConstr "Int")) 65 | ), 66 | ( "#pow" 67 | ,VFun $ \(VLit (ILit x)) -> VFun $ \(VLit (ILit y)) -> VLit $ DLit $ (fromIntegral x) ^^ y 68 | ,Scheme [] $ TFun (TConstr "Int") 69 | (TFun (TConstr "Int") 70 | (TConstr "Int")) 71 | ), 72 | ( "#mul" 73 | ,VFun $ \(VLit x) -> VFun $ \(VLit y) -> VLit $ x*y 74 | ,Scheme [] $ TFun (TConstr "Int") 75 | (TFun (TConstr "Int") 76 | (TConstr "Int")) 77 | ), 78 | ( "#div" 79 | ,VFun $ \(VLit (ILit x)) -> VFun $ \(VLit (ILit y)) -> VLit $ DLit $ (fromIntegral x)/(fromIntegral y) 80 | ,Scheme [] $ TFun (TConstr "Int") 81 | (TFun (TConstr "Int") 82 | (TConstr "Int")) 83 | ), 84 | ( "#gt" 85 | ,VFun $ \(VLit (ILit x)) -> VFun $ \(VLit (ILit y)) -> boolToVConstr (x>y) 86 | ,Scheme ["a"] $ TFun a (TFun a (TConstr "Boolean")) 87 | ), 88 | ( "#eq" 89 | ,VFun $ \(VLit (ILit x)) -> VFun $ \(VLit (ILit y)) -> boolToVConstr (x==y) 90 | ,Scheme ["a"] $ TFun a (TFun a (TConstr "Boolean")) 91 | ), 92 | ( "#not" 93 | ,VFun $ \v -> boolToVConstr $ not $ vConstrToBool v 94 | ,Scheme [] $ TFun (TConstr "Boolean") (TConstr "Boolean") 95 | ), 96 | ( "#or" 97 | ,VFun $ \v1 -> VFun $ \v2 -> boolToVConstr $ (vConstrToBool v1) || (vConstrToBool v2) 98 | ,Scheme [] $ TFun (TConstr "Boolean") (TFun (TConstr "Boolean") 99 | (TConstr "Boolean")) 100 | ), 101 | ( "#bind" 102 | ,VFun $ \(VIO a1) -> VFun $ \(VFun a2) -> VIO $ a1 >>= \s -> run $ a2 s -- a1 >>= \s -> a2 s 103 | ,undefined 104 | ), 105 | ( "#then" 106 | ,VFun $ \(VIO a1) -> VFun $ \(VIO a2) -> VIO $ a1 >> a2 107 | ,Scheme ["a","b"] $ TFun (TApp (TConstr "IO") a) 108 | (TFun (TApp (TConstr "IO") b) 109 | (TApp (TConstr "IO") b)) 110 | ), 111 | ( "(,)" 112 | ,vConstructor "(,)" 2 id 113 | ,Scheme ["a","b"] $ TFun a (TFun b (TApp (TApp (TConstr "(,)") a) b)) 114 | ), 115 | ( "(,,)" 116 | ,vConstructor "(,,)" 3 id 117 | ,Scheme ["a","b","c"] $ TFun a (TFun b (TFun c (TApp (TApp (TApp (TConstr "(,,)") a) b) c))) 118 | ), 119 | ( "Cons" 120 | ,vConstructor "Cons" 2 id 121 | ,Scheme ["a"] $ TFun a (TFun 122 | (TApp (TConstr "[]") a) 123 | (TApp (TConstr "[]") a)) 124 | ), 125 | ( "Nil" 126 | ,vConstructor "Nil" 0 id 127 | ,Scheme ["a"] $ TApp (TConstr "[]") a 128 | ) 129 | ] 130 | where a = TVar "a" 131 | b = TVar "b" 132 | c = TVar "c" 133 | 134 | vPrint :: Char -> IO Value 135 | vPrint c = putChar c >> return (VConstr "()" []) 136 | 137 | strToValue :: [Char] -> Value 138 | strToValue [] = VConstr "Nil" [] 139 | strToValue (c:cs) = VConstr "Cons" [VLit (CLit c), strToValue cs] 140 | 141 | vConstructor :: ConstrID -> Int -> ([Value] -> [Value]) -> Value 142 | vConstructor cid n k 143 | | n < 0 = error "vConstructor must be called with n >= 0" 144 | | n == 0 = VConstr cid $ k [] 145 | | otherwise = VFun $ \v -> vConstructor cid (n-1) $ (. (v:)) k 146 | 147 | run :: Value -> IO Value 148 | run act = case act of 149 | VIO a -> a 150 | _ -> error "faulty type" 151 | 152 | vConcat :: Value -> Value -> Value 153 | vConcat (VConstr "Nil" []) v2 = v2 154 | vConcat (VConstr "Cons" [v1, vs]) v2 = VConstr "Cons" [v1, (vConcat vs v2)] 155 | 156 | boolToVConstr :: Bool -> Value 157 | boolToVConstr b = VConstr (show b) [] 158 | 159 | vConstrToBool :: Value -> Bool 160 | vConstrToBool (VConstr "True" []) = True 161 | vConstrToBool (VConstr "False" []) = False 162 | -------------------------------------------------------------------------------- /AST/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module AST.Interpreter where 2 | 3 | import Data.Maybe 4 | import Text.Parsec 5 | import AST.Environment 6 | import AST.DataTypes 7 | import Data.Map 8 | import qualified Data.Map as M 9 | 10 | -- call interpret with io 11 | interpret :: Program -> IO () 12 | interpret (Program dd fd) = do 13 | let v = interpret' dd fd 14 | case v of 15 | VIO v -> v >> return () 16 | v -> (putStrLn $ show v) >> return () 17 | where 18 | interpret' dd fd = let e = addFuncDeclsToEnv e startEnv fd in 19 | lookupInEnv (addDataDeclsToEnv e dd) "main" 20 | 21 | addDataDeclsToEnv :: Env -> [DataDecl] -> Env 22 | addDataDeclsToEnv env [] = env 23 | addDataDeclsToEnv env ((DData _ _ cds):dds) = 24 | addDataDeclsToEnv (addManyToEnv env (fst vvs) (snd vvs)) dds 25 | where vvs = unzip $ Prelude.map mkConstr cds 26 | 27 | 28 | mkConstr :: ConstrDecl -> (String, Value) 29 | mkConstr (ConstrDecl name ts) = (name, (vConstructor name (length ts) id)) 30 | 31 | -- addDecsToEnv is a helper function to interpret 32 | -- Adds declarations to the environment 33 | addFuncDeclsToEnv :: Env -> Env -> [FuncDecl] -> Env 34 | addFuncDeclsToEnv env sEnv [] = sEnv 35 | addFuncDeclsToEnv env sEnv (d:ds) = insertAll e' (makeBinding d env) 36 | --addDecsToEnv env (d:ds) = uncurry M.insert (makeBinding d env) e' 37 | where 38 | e' = addFuncDeclsToEnv env sEnv ds 39 | 40 | insertAll :: Env -> [(Var,Value)] -> Env 41 | insertAll e [] = e 42 | insertAll e ((var,val):vs) = insertAll (addToEnv e var val) vs 43 | 44 | -- makeBinding is a helper function to addDecsToEnv 45 | -- Makes bindings from declarations to environment 46 | makeBinding :: FuncDecl -> Env -> [(Var, Value)] 47 | makeBinding (DFunc name _ vs e) env = [(name, val)] 48 | where 49 | addLams [] e = e 50 | addLams (v:vs) e = ELam v (addLams vs e) 51 | val = eval env (addLams vs e) 52 | 53 | -- startEnv creates the basic environment 54 | startEnv :: Env 55 | startEnv = startEnv' M.empty startEnvironment 56 | where 57 | startEnv' :: Env -> [(String, Value, Scheme)] -> Env 58 | startEnv' env [] = env 59 | startEnv' env ((a,b,c):xs) = startEnv' (M.insert a b env) xs 60 | 61 | -- evaluation of an expression in an environment 62 | eval :: Env -> Exp -> Value 63 | eval env expr = case expr of 64 | ELetIn var e1 e2 -> eval env' e2 65 | where env' = addToEnv env var (eval env' e1) 66 | EConstr cid -> lookupInEnv env cid 67 | EApp e1 e2 -> case (eval env e1) of 68 | VFun v1 -> v1 v2 69 | where v2 = eval env e2 70 | _ -> VConstr "Undefined" [] 71 | ELam var e -> VFun $ \v -> eval (addToEnv env var v) e 72 | EVar var -> lookupInEnv env var 73 | ELit lit -> VLit lit 74 | EUnOp op e -> f $ eval env e 75 | where (VFun f) = lookupInEnv env (show op) 76 | EBinOp op e1 e2 -> f $ eval env e2 77 | where (VFun f') = lookupInEnv env (show op) 78 | (VFun f) = f' $ eval env e1 79 | ECase expr' [] -> VLit (ILit 0) 80 | ECase expr' pEs -> fromJust $ evalCase v env pEs 81 | where v = eval env expr' 82 | 83 | -- evalCase is a helper function to eval. 84 | evalCase :: Value -> Env -> [(Pattern, Exp)] -> Maybe Value 85 | evalCase _ _ [] = Nothing 86 | evalCase v env ((p, expr):pes) = case match p v of 87 | Just vvs -> Just $ eval env' expr 88 | where 89 | vvs' = unzip vvs -- ([vars], [vals]) 90 | env' = addManyToEnv env (fst vvs') (snd vvs') 91 | Nothing -> evalCase v env pes 92 | 93 | -- match is a helper function to evalCase. It takes a pattern and a value and 94 | -- returns the bidings introduced by the patterns (Nothing if the value doesn't 95 | -- match the pattern). 96 | match :: Pattern -> Value -> Maybe [(Var, Value)] 97 | match PWild _ = Just [] 98 | match (PLit pl) (VLit vl) 99 | | pl == vl = Just [] 100 | | otherwise = Nothing 101 | match (PVar pv) var = Just [(pv, var)] 102 | match (PConstr pcid ps) (VConstr vcid vs) 103 | | pcid == vcid = matchConstr ps vs 104 | | otherwise = Nothing 105 | 106 | matchConstr :: [Pattern] -> [Value] -> Maybe [(Var,Value)] 107 | matchConstr ps vs = fmap concat $ sequence (zipWith match ps vs) 108 | -------------------------------------------------------------------------------- /Converter.hs: -------------------------------------------------------------------------------- 1 | -- to run file : 2 | -- $ bnfc -m grammar.cf 3 | -- $ runghc -iAST/:grammar/ Converter.hs 4 | 5 | module Converter where 6 | 7 | import qualified AST.DataTypes as D 8 | import TI 9 | import AbsGrammar 10 | import qualified AbsGrammar as A 11 | 12 | main :: IO () 13 | main = putStrLn "welcome to the converter" 14 | 15 | cProgram :: A.Program -> D.Program 16 | cProgram p = D.Program [cDataDecl d | d@(A.DData tId ids cs) <- ds] -- ++[cTypeDecl td | td@(A.DSyn tId ids t d) <- ds] 17 | [cFuncDecl f | f@(A.DFunc fId t ds) <- ds] 18 | where ds = progToDecls p 19 | 20 | -- Recursively converts the program to internal syntax by 21 | -- repeatedly applying cDeclaration to each declaration 22 | progToDecls :: A.Program -> [A.Declaration] 23 | progToDecls (A.PFuncs d p) = d:(progToDecls p) 24 | progToDecls (A.PLast d) = [d] 25 | 26 | -- Converts a function declaration to a case-expression in DataTypes 27 | cFuncDecl :: A.Declaration -> D.FuncDecl 28 | cFuncDecl (A.DFunc (A.Id name) tDecls defs) 29 | | not sameNbrAs -- definitons has different number of arguments 30 | = error $ "Defintions for function " ++ name ++ " have different number of arguments" 31 | | nbrAs == 0 && length defs > 1 -- if there is no input arguments, but several defs 32 | = error $ "Conflicting definitions for function " ++ name 33 | | nbrAs >= 1 -- pattern matching can arrise 34 | = D.DFunc name (cType tDecls) linVs (defsToCase linVs linVs defs') 35 | | otherwise = D.DFunc name (cType tDecls) [] (defToExp $ head defs) -- pattern matching can't arrise 36 | where vars = take (countAs $ head defs) variables -- reserves variables for the input arguments 37 | linVs = linearize vars (typeDeclToList tDecls) -- creates linear variables 38 | nbrAs = countAs $ head defs -- an arbitrary definitions number of arguments 39 | countAs (A.DDef _ as _) = length as -- counts number of arguments of a definition 40 | countAs (A.DGuardsDef _ as _) = length as -- counts number of arguments of a definition 41 | sameNbrAs = all (== nbrAs) (map countAs defs) -- all defs should have same number of arguments 42 | defs' = allDef defs 43 | 44 | -- converts the recurive datatype Type to a list of 45 | -- TypeIdents 46 | typeDeclToList :: A.Type -> [A.TypeIdent] 47 | typeDeclToList (TypeIds ti) = [ti] 48 | typeDeclToList (TypeTuple t ts) = concatMap typeDeclToList (t:ts) 49 | typeDeclToList (TypeList t) = typeDeclToList t 50 | typeDeclToList TypeVoid = [] 51 | typeDeclToList (TypeDecl t1 t2) = (typeDeclToList t1)++(typeDeclToList t2) 52 | typeDeclToList (LiTypeDecl t1 t2) = (typeDeclToList t1)++(typeDeclToList t2) 53 | typeDeclToList (TypeApp t1 t2) = (typeDeclToList t1)++(typeDeclToList t2) 54 | 55 | -- linearizes linear variables for use in interpreter 56 | linearize :: [D.Var] -> [A.TypeIdent] -> [D.Var] 57 | linearize [] _ = [] 58 | linearize vs [] = vs 59 | linearize (v:vs) (t:ts) = case t of 60 | STypeIdent (TypeId name) -> v:(linearize vs ts) 61 | LiTypeIdent (Id ('i':_)) -> ('i':v):(linearize vs ts) 62 | LiTypeIdent (Id name) -> v:(linearize vs ts) 63 | 64 | -- Converts a data declaration to a DataDecl in DataTypes 65 | cDataDecl :: A.Declaration -> D.DataDecl 66 | cDataDecl (DData (STypeIdent (TypeId s)) ids cs) = D.DData s [name | Id name <- ids] (map cConstr cs) 67 | 68 | -- Converts a type declaration to a DataDecl in DataTypes 69 | -- cTypeDecl :: A.Declaration -> D.DataDecl 70 | -- cTypeDecl (DSyn (STypeIdent (TypeId s)) ids t d) = D.DData s [name | Id name <- ids] (map cConstr cs) 71 | 72 | -- Converts a constructor 73 | cConstr :: A.Constr -> D.ConstrDecl 74 | cConstr (DConstr1 tId tps) = 75 | case tId of 76 | (STypeIdent (TypeId s)) -> D.ConstrDecl s [cType t | (TParameter t) <- tps] -- TODO lägg till s som en typ i miljön 77 | (LiTypeIdent (Id s)) -> D.ConstrDecl s [cType t | (TParameter t) <- tps] 78 | 79 | typeToVal :: A.Type -> D.Value -- TODO 80 | typeToVal t = case t of 81 | TypeIds (STypeIdent (TypeId t1)) -> D.VConstr t1 [] 82 | TypeIds (LiTypeIdent (Id t1)) -> undefined -- TODO 83 | TypeTuple t1 t2 -> case length t2 of 84 | 1 -> D.VConstr "(,)" [typeToVal $ t1, (typeToVal $ head t2)] 85 | 2 -> D.VConstr "(,,)" [typeToVal t1, (typeToVal $ head t2), (typeToVal $ head $ drop 1 $ t2)] 86 | -- TypeList, this is now a TConstr "[]", fix accordingly 87 | TypeVoid -> undefined 88 | TypeDecl t1 t2 -> undefined 89 | LiTypeDecl t1 t2 -> undefined 90 | TypeApp t1 t2 -> undefined 91 | 92 | -- Converts types from the surface syntax to a minimized set of types used by the typechecker. 93 | cType :: A.Type -> D.Type 94 | cType (A.TypeIds (A.STypeIdent s)) = D.TConstr $ extractTId s 95 | cType (A.TypeIds (A.LiTypeIdent s)) = D.TVar $ extractId s 96 | cType (A.TypeTuple t1 ts) = case ts of 97 | (t2:[]) -> D.TApp (D.TApp (D.TConstr "(,)") (cType t1)) (cType t2) 98 | (t2:t3:[]) -> D.TApp (D.TApp (D.TApp (D.TConstr "(,)") (cType t1)) (cType t2)) (cType t3) 99 | _ -> error "Tuples only defined for two or three elements." 100 | cType (A.TypeList t ) = D.TApp (D.TConstr "[]") (cType t) 101 | cType A.TypeVoid = D.TConstr "()" 102 | cType (A.TypeDecl t1 t2) = D.TFun (cType t1) (cType t2) 103 | cType (A.LiTypeDecl t1 t2) = D.TFun (cType t1) (cType t2) 104 | cType (A.TypeApp t1 t2) = D.TApp (cType t1) (cType t2) 105 | 106 | -- Converts type indentifiers to actual strings 107 | identToString :: A.TypeIdent -> String 108 | identToString (A.STypeIdent s) = extractTId s 109 | identToString (A.LiTypeIdent s) = extractId s 110 | 111 | -- Extracts the string from a TypeId / Id 112 | extractTId :: A.TypeId -> String 113 | extractTId (A.TypeId s) = s 114 | extractId :: A.Id -> String 115 | extractId (A.Id s) = s 116 | 117 | 118 | -- Extracts the expression from a def 119 | defToExp :: A.Def -> D.Exp 120 | defToExp (A.DDef _ _ e) = cExp e 121 | defToExp (A.DGuardsDef _ _ gs) = cExp $ cGuard gs 122 | 123 | -- converts a number of definitions to case-tree 124 | -- first matches the first argument to firt input variable then 125 | -- creates following case-trees 126 | 127 | defsToCase :: [D.Var] -> [D.Var] -> [A.Def] -> D.Exp 128 | defsToCase _ (v:[]) ((A.DDef _ (a:[]) e):[]) 129 | = D.ECase (D.EVar v) [((argToPat a), (cExp e))] 130 | defsToCase vsOrg (v:vs) ((A.DDef did (a:as) e):[]) 131 | = D.ECase (D.EVar v) [((argToPat a), 132 | (defsToCase vsOrg vs [(A.DDef did as e)]))] 133 | defsToCase vsOrg (v:[]) ((A.DDef _ (a:[]) e):ds) 134 | = D.ECase (D.EVar v) 135 | [ ((argToPat a), (cExp e)), 136 | (D.PWild, (defsToCase vsOrg vsOrg ds))] 137 | defsToCase vsOrg (v:vs) ((A.DDef did (a:as) e):ds) = 138 | D.ECase (D.EVar v) 139 | [ ((argToPat a), (defsToCase vsOrg vs ((A.DDef did as e):ds))), 140 | (D.PWild, (defsToCase vsOrg vsOrg ds))] 141 | 142 | -- translates all definitions into DDef-definitions 143 | allDef :: [A.Def] -> [A.Def] 144 | allDef [] = [] 145 | allDef (d:ds) = case d of 146 | (A.DDef _ _ _) -> d:(allDef ds) 147 | (A.DGuardsDef did as gs) -> (A.DDef did as (cGuard gs)):(allDef ds) 148 | 149 | 150 | -- translates guards into equal case-expressions 151 | cGuard :: A.Guards -> A.Exp 152 | cGuard (A.DGuards1 e1 e2 gs) = cGuard (A.DGuards2 e1 e2 gs) 153 | cGuard (A.DGuards2 e1 e2 gs) = 154 | A.ECase e2 (A.ECases2 (A.PConstrEmp (A.TypeId "True")) e1 (cGuard' gs)) 155 | where 156 | cGuard' (A.DGuards2 _ _ _) = (A.ECases3 A.PWild (cGuard gs)) 157 | cGuard' (A.DExpGuard e) = (A.ECases3 A.PWild e) 158 | cGuard (A.DExpGuard e) = A.ECase e ((A.ECases3 (A.PWild)) e) 159 | -- last one is "otherwise"-case 160 | 161 | 162 | -- list of generated variables to introduce in declaration 163 | variables :: [D.Var] 164 | variables = map (("#x"++).show) [1..] 165 | 166 | 167 | -- converts args to pat in DataTypes.hs 168 | -- where Pat = PLit Lit | PWild | PVar Var 169 | argToPat :: A.Arg -> D.Pattern 170 | argToPat (A.DArg p) = cPattern p 171 | 172 | typeIdentName :: A.TypeIdent -> String 173 | typeIdentName (STypeIdent (TypeId name)) = name 174 | typeIdentName (LiTypeIdent (Id name)) = name 175 | 176 | -- Converts a pattern 177 | cPattern :: A.Pattern -> D.Pattern 178 | cPattern p = case p of 179 | A.PTuplePat p1 p2 -> D.PConstr "(,)" $ Prelude.map cPattern [p1,p2] 180 | A.PTruplePat p1 p2 p3 -> D.PConstr "(,,)" $ Prelude.map cPattern [p1,p2,p3] 181 | A.PListPat lp -> cLPat lp 182 | A.PWild -> D.PWild 183 | A.PId (A.Id name) -> D.PVar name 184 | A.PLit l -> case l of 185 | A.LitString str -> strToPat str 186 | _ -> D.PLit (cLit l) 187 | A.PConstrEmp (TypeId name) -> D.PConstr name [] 188 | A.PCons p1 p2 -> D.PConstr "Cons" [(cPattern p1), (cPattern p2)] 189 | A.PDataConstr ts p ps -> D.PConstr (typeIdentName ts) (map cPattern (p:ps)) 190 | -- (A.PConsConstr (TypeId name) p1 ps p2) -> D.PConstr "Cons" [(D.PConstr name (map cPattern (p1:ps))), (cPattern p2)] 191 | A.PEmpty -> D.PConstr "Nil" [] 192 | 193 | -- converts a string to a pattern in core syntax 194 | strToPat :: String -> D.Pattern 195 | strToPat [] = D.PConstr "Nil" [] 196 | strToPat (c:cs) = D.PConstr "Cons" [D.PLit (D.CLit c), strToPat cs] 197 | 198 | -- Converts a list pattern 199 | cLPat :: A.ListPat -> D.Pattern 200 | cLPat (A.PList2 p lp) = D.PConstr "Cons" [(cPattern p), (cLPat lp)] 201 | cLPat (A.PList1 p ) = D.PConstr "Cons" [(cPattern p), (D.PConstr "Nil" [])] 202 | 203 | 204 | -- Converts a literal 205 | cLit :: A.Literal -> D.Lit 206 | cLit (A.LitInt x) = D.ILit $ fromInteger x 207 | cLit (A.LitDouble x) = D.DLit x 208 | cLit (A.LitChar x) = D.CLit x 209 | 210 | 211 | -- Converts a constructor 212 | cConst :: A.Cons -> D.Exp 213 | cConst (A.DConst1 (A.TypeId cid) cid' ids) = D.EConstr cid 214 | cConst (A.DConst2 (A.TypeId cid)) = D.EConstr cid 215 | 216 | -- Converts a string to an expression in core syntax 217 | strToExp :: String -> D.Exp 218 | strToExp [] = D.EConstr "Nil" 219 | strToExp (c:cs) = D.EApp (D.EApp (D.EConstr "Cons") (D.ELit (D.CLit c))) (strToExp cs) 220 | 221 | -- Converts an expression 222 | cExp :: A.Exp -> D.Exp 223 | cExp (A.EVar (A.Id name)) = (D.EVar name) 224 | cExp (A.ETuple t) = cTuple t 225 | cExp (A.ELiteral lit) = case lit of 226 | A.LitString str -> strToExp str 227 | _ -> (D.ELit $ cLit lit) 228 | cExp (A.EConst c) = case c of 229 | (A.DConst2 (A.TypeId name)) -> (D.EConstr name) 230 | -- cExp (A.EListComp e lcps) 231 | cExp (A.EList ls) = cList ls 232 | cExp A.EEmptyList = D.EConstr "Nil" 233 | cExp (A.ELet (Id n) e1 e2) = (D.ELetIn n (cExp e1) (cExp e2)) 234 | cExp (A.EApp e1 e2) = (D.EApp (cExp e1) (cExp e2)) 235 | cExp (A.ELogicalNeg e) = (D.EUnOp D.Not (cExp e)) 236 | cExp (A.ENeg e) = (D.EBinOp D.Mul (cExp e) (D.ELit (D.ILit (-1)))) 237 | cExp (A.EConcat e1 e2) = (D.EBinOp D.Concat (cExp e1) (cExp e2)) 238 | cExp (A.ECons e1 e2) = (D.EBinOp D.Cons (cExp e1) (cExp e2)) 239 | cExp (A.EPow e1 e2) = (D.EBinOp D.Pow (cExp e1) (cExp e2)) 240 | cExp (A.EMul e1 e2) = (D.EBinOp D.Mul (cExp e1) (cExp e2)) 241 | cExp (A.EDiv e1 e2) = (D.EBinOp D.Div (cExp e1) (cExp e2)) 242 | cExp (A.EAdd e1 e2) = (D.EBinOp D.Add (cExp e1) (cExp e2)) 243 | cExp (A.ESub e1 e2) = (D.EBinOp D.Add (cExp e1) (cExp (A.ENeg e2))) 244 | cExp (A.ELt e1 e2) = (D.EBinOp D.Gt (cExp e2) (cExp e1)) 245 | cExp (A.EGt e1 e2) = (D.EBinOp D.Gt (cExp e1) (cExp e2)) 246 | cExp (A.ELEq e1 e2) = (D.EBinOp D.Or (cExp (A.ELt e1 e2)) (cExp (A.EEq e1 e2))) 247 | cExp (A.EGEq e1 e2) = (D.EBinOp D.Or (cExp (A.EGt e1 e2)) (cExp (A.EEq e1 e2))) 248 | cExp (A.EEq e1 e2) = (D.EBinOp D.Eq (cExp e1) (cExp e2)) 249 | cExp (A.ENEq e1 e2) = (D.EUnOp D.Not (D.EBinOp D.Eq (cExp e1) (cExp e2))) 250 | cExp (A.EAnd e1 e2) = D.EUnOp D.Not $ D.EBinOp D.Or (D.EUnOp D.Not (cExp e1)) (D.EUnOp D.Not (cExp e2)) 251 | cExp (A.EOr e1 e2) = (D.EBinOp D.Or (cExp e1) (cExp e2)) 252 | cExp (A.EBind e1 e2) = (D.EBinOp D.Bind (cExp e1) (cExp e2)) 253 | cExp (A.ESeq e1 e2) = (D.EBinOp D.Then (cExp e1) (cExp e2)) 254 | cExp (A.ECase e cs) = (D.ECase (cExp e) (cCase cs)) 255 | cExp (A.EIf e1 e2 e3) = (D.ECase (cExp e1) [((D.PConstr "True" []), (cExp e2)), 256 | ((D.PConstr "False" []), (cExp e3))]) 257 | cExp (A.EAbs (A.Id n) ns e) = (D.ELam n (cList' ns e)) 258 | where cList' ((A.Id n):ns) e = (D.ELam n (cList' ns e)) 259 | cList' [] e = cExp e 260 | 261 | 262 | -- Converts a list of expressions 263 | cList :: [A.Exp] -> D.Exp 264 | cList [] = D.EConstr "Nil" 265 | cList ls = case (head ls) of 266 | ELiteral (LitString str) -> cStrLitList ls 267 | ELiteral _ -> cLitList ls 268 | ENeg _ -> cLitList ls 269 | ETuple _ -> cTupleList ls 270 | EConst _ -> cConstList ls 271 | EList _ -> cListList ls 272 | EVar (Id a) -> D.EApp ((D.EApp (D.EConstr "Cons") (D.EVar a))) (cList $ tail ls) 273 | _ -> error $ "\nError in cList, unable to parse expression: " ++ show (head ls) 274 | 275 | cStrLitList :: [A.Exp] -> D.Exp 276 | cStrLitList [] = D.EConstr "Nil" 277 | cStrLitList ((A.ELiteral (A.LitString l)):ls) = 278 | D.EApp ((D.EApp (D.EConstr "Cons") (strToExp l))) (cStrLitList ls) 279 | 280 | -- Converts a list of lists 281 | cListList :: [A.Exp] -> D.Exp 282 | cListList [] = D.EConstr "Nil" 283 | cListList (l:ls) = D.EApp ((D.EApp (D.EConstr "Cons") (cExp l))) (cListList ls) 284 | 285 | 286 | -- Converts a list of tuples 287 | cTupleList :: [A.Exp] -> D.Exp 288 | cTupleList [] = D.EConstr "Nil" 289 | cTupleList ((A.ETuple t):ts) = D.EApp ((D.EApp (D.EConstr "Cons") (cTuple t))) (cTupleList ts) 290 | 291 | 292 | -- Converts a list of constructors 293 | cConstList :: [A.Exp] -> D.Exp 294 | cConstList [] = D.EConstr "Nil" 295 | cConstList ((A.EConst c):cs) = D.EApp ((D.EApp (D.EConstr "Cons") (cConst c))) (cConstList cs) 296 | 297 | 298 | -- Converts a list of literals 299 | cLitList :: [A.Exp] -> D.Exp 300 | cLitList [] = D.EConstr "Nil" 301 | cLitList (l:ls) = let l' = case l of 302 | ENeg (ELiteral (LitInt l)) -> LitInt $ -1*l 303 | ENeg (ELiteral (LitDouble l)) -> LitDouble $ -1*l 304 | ELiteral l -> l 305 | in D.EApp ((D.EApp (D.EConstr "Cons") (D.ELit $ cLit l'))) (cLitList ls) 306 | 307 | 308 | -- Converts a case expression 309 | cCase :: A.Cases -> [(D.Pattern, D.Exp)] 310 | cCase (A.ECases3 p e) = [((cPattern p),(cExp e))] 311 | cCase (A.ECases1 p e cs) = cCase (A.ECases2 p e cs) 312 | cCase (A.ECases2 p e cs) = ((cPattern p),(cExp e)):(cCase cs) 313 | 314 | -- Converts a tuple 315 | cTuple :: A.Tuple -> D.Exp 316 | cTuple (A.Tuple1 e1 e2) = D.EApp (D.EApp (D.EVar "(,)") (cExp e1)) (cExp e2) 317 | cTuple (A.Tuple2 e1 e2 e3) = D.EApp (D.EApp (D.EApp (D.EVar "(,,)") (cExp e1)) (cExp e2)) (cExp e3) 318 | 319 | {--cGuard :: A.Guards -> A.Exp 320 | cGuard (A.DGuards1 e1 e2 gs) = D.ECase (cExp e2) [((D.PConstr "True" []), (cExp e1)), 321 | ((D.PConstr "False" []), (cGuard gs))] 322 | cGuard (A.DGuards2 e1 e2 gs) = D.ECase (cExp e2) [((D.PConstr "True" []), (cExp e1)), 323 | ((D.PConstr "False" []), (cGuard gs))] 324 | cGuard (A.DExpGuard e) = (cExp e)--} 325 | -------------------------------------------------------------------------------- /Lollipop_project_poster.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/m0ar/lollipop/fffaf13b831b819b8e8a309468147874a8097727/Lollipop_project_poster.pdf -------------------------------------------------------------------------------- /Lollipop_publish.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/m0ar/lollipop/fffaf13b831b819b8e8a309468147874a8097727/Lollipop_publish.pdf -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![lollipop logo](logo.png) 2 | 3 | lollipop is a general purpose, functional programming language with support for linear types. This is a bachelor thesis project at Chalmers University of Technology, Gothenburg. 4 | 5 | ### Goal 6 | The main goal is to develop a proof-of-concept of linear types in a basic functional language. This is to enable easy access to the concept for developers that are interested in learning about linear types, in a practical environment. 7 | 8 | The project thesis can be found [HERE!](https://github.com/m0ar/lollipop/blob/develop/Lollipop_publish.pdf) 9 | 10 | ### Running programs in lollipop 11 | The lollipop interpreter, loli, (loli.hs) is used to load and run programs written in lollipop (.lp). 12 | 13 | #### Requirements 14 | The lollipop interpreter is built in Haskell and therefore requires the Glasgow Haskell Compiler, GHC to run. 15 | 16 | #### Running the lollipop interpreter 17 | To run the lollipop interpreter, fire up a terminal, move to the lollipop root directory and execute 18 | 19 | runghc -iAST/:grammar/ loli.hs 20 | 21 | It will take some time loading the interpreter, but when it's done the terminal will prompt: 22 | 23 | > 24 | 25 | From here you can load lollipop programs (ending with .lp) by using `:l`, reloading programs using `:r` and leaving the interpreter by `:q`. 26 | 27 | E.g: Loading of the program sugar (filename sugar.lp): 28 | 29 | >:l sugar 30 | Successfully loaded sugar 31 | sugar> 32 | 33 | From here you can execute functions and expressions in the loaded program 34 | 35 | E.g: Running some basic functions in sugar 36 | 37 | >:l sugar 38 | Successfully loaded sugar 39 | sugar> fac 5 40 | 120 41 | sugar> head [7,8,9] 42 | 7 43 | sugar> map (\x -> x+2) [4,6,8] 44 | [6,8,10] 45 | 46 | #### Disclaimer 47 | As for now the lollipop interpreter is in a beta-phase and syntax-errors and unsuccessfully loaded programs can cause it to crash. In this case, restart it using the same command again: 48 | 49 | runghc -iAST/:grammar/ loli.hs 50 | 51 | In rare cases the interpreter gets stuck in an evaluation loop. If the interpreter does this, try ending the process using ctrl+c, or by killing the ghc-process. 52 | -------------------------------------------------------------------------------- /TI.hs: -------------------------------------------------------------------------------- 1 | module TI where 2 | import qualified Data.Map as M 3 | import qualified Data.Set as S 4 | import Data.Maybe 5 | import Control.Monad.State 6 | import Control.Monad.Except 7 | import Data.Map(Map) 8 | import AST.DataTypes 9 | import AST.Environment 10 | import Control.Exception 11 | 12 | class Types a where 13 | ftv :: a -> S.Set Var 14 | apply :: Subst -> a -> a 15 | 16 | 17 | instance Types Type where 18 | ftv (TVar n) = S.singleton n 19 | ftv (TFun t1 t2) = ftv t1 `S.union` ftv t2 20 | ftv (TConstr _) = S.empty 21 | ftv (TApp t1 t2) = ftv t1 `S.union` ftv t2 22 | apply s (TVar n) = fromMaybe (TVar n) (M.lookup n s) 23 | apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2) 24 | apply s (TApp t1 t2) = TApp (apply s t1) (apply s t2) 25 | apply _ t = t 26 | 27 | instance Types Scheme where 28 | ftv (Scheme vars t) = ftv t `S.difference` S.fromList vars 29 | apply s (Scheme vars t) = Scheme vars (apply (foldr M.delete s vars) t) 30 | 31 | instance Types a => Types [a] where 32 | apply s = map (apply s) 33 | ftv = foldr (S.union . ftv) S.empty 34 | 35 | 36 | -- A type t is actual wrt. a substitution s if no type variables in t are mapped in s 37 | -- Invariant: All types in any substitution s must be actual wrt. s 38 | type Subst = Map Var Type 39 | 40 | composeSubst :: Subst -> Subst -> Subst 41 | composeSubst s1 s2 = M.map (apply s1) s2 `M.union` s1 42 | 43 | 44 | --data TIEnv = TIEnv {} remove? 45 | data TIState = TIState {tiSupply :: Int, 46 | tiSubst :: Subst} 47 | 48 | type TI a = ExceptT String (State TIState) a 49 | 50 | runTI :: TI a -> (Either String a, TIState) 51 | runTI t = runState (runExceptT t) initTIState 52 | where initTIState = TIState{tiSupply = 0, 53 | tiSubst = M.empty} 54 | 55 | 56 | newTyVar :: String -> TI Type 57 | newTyVar prefix = do 58 | s <- get 59 | put s{tiSupply = tiSupply s + 1} 60 | return (TVar (prefix ++ show (tiSupply s))) 61 | 62 | -- "Refresh" the type to make sure it is actual wrt. the current substitution 63 | refresh :: Type -> TI Type 64 | refresh t = do 65 | s <- gets tiSubst 66 | return (apply s t) 67 | 68 | debugTI :: TI a 69 | debugTI = do 70 | s <- gets tiSubst 71 | error $ show s 72 | 73 | unify :: Type -> Type -> TI Type 74 | unify t1 t2 = do 75 | go t1 t2 76 | where 77 | go (TFun l1 r1) (TFun l2 r2) = do 78 | m1 <- go l1 l2 79 | m2 <- go r1 r2 80 | return $ TFun m1 m2 81 | go (TVar u) t = varBind u t 82 | go t (TVar u) = varBind u t 83 | go (TConstr a) (TConstr b) | a == b = return $ TConstr a 84 | go (TApp l1 r1) (TApp l2 r2)= do 85 | m1 <- go l1 l2 86 | m2 <- go r1 r2 87 | return $ TApp m1 m2 88 | go (TConstr "Undefined") a = return a 89 | go a (TConstr "Undefined") = return a 90 | go e1 e2 = throwError $ "types do not unify: " ++ show e1 ++ 91 | " vs. " ++ show e2 92 | 93 | unifyAll :: [Type] -> TI Type 94 | unifyAll [t] = return t 95 | unifyAll (t:ts) = unifyAll ts >>= unify t -- Does a lot of needless refreshing... 96 | 97 | 98 | varBind :: Var -> Type -> TI Type 99 | varBind u t = do 100 | u' <- refresh $ TVar u 101 | case u' of 102 | TVar u'' -> refresh t >>= varBind' u'' 103 | _ -> unify u' t 104 | where 105 | varBind' :: Var -> Type -> TI Type 106 | varBind' u t | t == TVar u = return t 107 | | u `S.member` ftv t = throwError $ "occur check fails: " ++ u ++ 108 | " vs. " ++ show t 109 | | otherwise = do 110 | let newSubst = M.singleton u t 111 | modify (\s -> s{tiSubst = composeSubst newSubst (tiSubst s) } ) 112 | return t 113 | 114 | ti :: TypeEnv -> Exp -> TI Type 115 | ti (TypeEnv env) (EVar v) = case M.lookup v env of 116 | Nothing -> throwError $ "unbound variable: " ++ v 117 | Just v' -> instantiate v' 118 | ti _ (ELit l) = case l of 119 | ILit _ -> return $ TConstr "Int" 120 | DLit _ -> return $ TConstr "Double" 121 | CLit _ -> return $ TConstr "Char" 122 | ti env (EUnOp o e) = case o of -- TODO 123 | Not -> do 124 | t1 <- ti env e 125 | t2 <- ti env (EConstr "True") 126 | unify t1 t2 127 | _ -> throwError $ "Not a unary operator" -- Should this be here or in DataTypes? 128 | ti env (EBinOp u e1 e2) = ti env (EApp (EApp (EVar (show u)) e1) e2) 129 | ti env (ELam v e) = do 130 | t0 <- newTyVar "a" 131 | let TypeEnv env' = remove v env 132 | env'' = TypeEnv (env' `M.union` M.singleton v (Scheme [] t0)) 133 | t1 <- ti env'' e 134 | return (TFun t0 t1) 135 | ti env (EConstr id) = lookupType env id 136 | ti env (ECase e0 pes) = do 137 | t0 <- ti env e0 138 | let go (p, e) = do 139 | let pvs = freeVarsP p 140 | env' <- declareAll pvs env 141 | tp <- ti env' (patToExp p) 142 | unify tp t0 143 | ti env' e 144 | ts <- mapM go pes 145 | unifyAll ts 146 | ti env (EApp e1 e2) = do 147 | t1 <- ti env e1 148 | t2 <- ti env e2 149 | a <- newTyVar "a" 150 | unify (TFun t2 a) t1 151 | return a 152 | ti env (ELetIn v e1 e2) = do 153 | t1 <- ti env e1 154 | let TypeEnv env' = remove v env 155 | t' = generalize env t1 156 | env'' = TypeEnv (M.insert v t' env') 157 | ti env'' e2 158 | 159 | progToTypeEnv :: Program -> TypeEnv 160 | progToTypeEnv (Program dds fds) = TypeEnv $ M.fromList $ concatMap dDecl dds ++ map fDecl fds 161 | 162 | fDecl :: FuncDecl -> (Var, Scheme) 163 | fDecl (DFunc id t vs _) = (id, Scheme (S.toList (ftv t)) t) 164 | --fDecl (DFunc id t vs _) = (id, Scheme (S.toList (ftv t)) t):(varsToScheme t vs) 165 | --fDecl (DFunc id t vs _) = (id, (Scheme vs t)) 166 | 167 | {--varsToScheme :: Type -> [Var] -> [(Var, Scheme)] 168 | varsToScheme _ [] = [] 169 | varsToScheme t (v:vs) = case t of 170 | TVar var -> [(v, Scheme (S.toList (ftv t)) t)] 171 | TiVar var -> [(v, Scheme (S.toList (ftv t)) t)] 172 | TConstr cid -> [(cid, Scheme (S.toList (ftv t)) t)] 173 | TiConstr cid -> [(cid, Scheme (S.toList (ftv t)) t)] 174 | TFun t1 t2 -> (v, Scheme (S.toList (ftv t)) t1):(varsToScheme t2 vs) 175 | TApp t1 t2 -> (v, Scheme (S.toList (ftv t)) t1):(varsToScheme t2 vs)--} 176 | 177 | -- (TFun (TVar "Int") (TFun (TVar "Int") (TFun (TVar "Int") (TVar "Int")))) 178 | 179 | {--data Type = 180 | TVar Var 181 | | TiVar Var 182 | | TConstr ConstrID 183 | | TiConstr ConstrID 184 | | TFun Type Type 185 | | TApp Type Type--} 186 | 187 | dDecl :: DataDecl -> [(ConstrID, Scheme)] 188 | dDecl (DData id vars cs) = map (schemify . cDecl tres) cs 189 | where 190 | -- Check that there aren't free variables in vars 191 | schemify (id, t) = (id, Scheme vars t) 192 | tres = foldl TApp (TConstr id) (map TVar vars) 193 | 194 | cDecl :: Type -> ConstrDecl -> (ConstrID, Type) 195 | cDecl t (ConstrDecl id ts) = (id, foldr TFun t ts) 196 | 197 | infer :: TypeEnv -> Exp -> TI Type 198 | infer env ex = ti env ex >>= refresh 199 | 200 | -- checks that no linear variables occurs more than once in an expression 201 | linearCheck :: (M.Map Var Int) -> TypeEnv -> Exp -> Bool 202 | linearCheck m te e = let lst = (M.filterWithKey (\k v -> v /= 1 && (isLinear te k)) (lc e te m)) in 203 | case M.size lst of 204 | 0 -> True 205 | n -> throw $ LinearException $ (show lst) 206 | 207 | isLinear :: TypeEnv -> Var -> Bool 208 | isLinear te v = case lookupType' te v of 209 | (Scheme vs t) -> isLinear' t 210 | where isLinear' t = case t of 211 | (TiVar _) -> True 212 | (TiConstr _) -> True 213 | (TVar ('i':_)) -> True 214 | (TConstr ('i':_)) -> True 215 | _ -> False 216 | 217 | lc :: Exp -> TypeEnv -> (M.Map Var Int) -> (M.Map Var Int) 218 | lc e tEnv m = case e of 219 | (EApp e1 e2) -> lc e1 tEnv (lc e2 tEnv m) 220 | (EVar var) -> if isLinear tEnv var 221 | then M.insertWith (+) var 1 m 222 | else m 223 | (ELit _) -> m 224 | (EUnOp _ e) -> lc e tEnv m 225 | (EBinOp _ e1 e2) -> lc e1 tEnv (lc e2 tEnv m) 226 | (ELam var e) -> if isLinear tEnv var 227 | then M.insertWith (+) var 1 m 228 | else m 229 | (EConstr cid) -> if isLinear tEnv cid 230 | then M.insertWith (+) cid 1 m 231 | else m 232 | (ECase ex pes) -> let env = lc ex tEnv m 233 | es = (map snd pes) 234 | lst = map (linearCheck env tEnv) es 235 | in case (and lst) of 236 | True -> env 237 | False -> error $ "m: " ++ (show m) ++ " es: " ++ (show es) -- throw LinearException 238 | (ELetIn _ e1 e2) -> lc e1 tEnv (lc e2 tEnv m) 239 | (EListComp e2 vvs e1) -> undefined 240 | 241 | 242 | -- Returns the free expression variables in patterns 243 | freeVarsP :: Pattern -> [Var] 244 | freeVarsP (PConstr v vs) = concatMap freeVarsP vs 245 | freeVarsP (PVar v) = [v] 246 | freeVarsP _ = [] 247 | 248 | -- Adds new type variables for each expression variables 249 | declareAll :: [String] -> TypeEnv -> TI TypeEnv 250 | declareAll [] env = return env 251 | declareAll (x:xs) env = do 252 | a <- newTyVar "a" 253 | declareAll xs $ declareMono x a env 254 | 255 | -- Converts a pattern to an expression 256 | patToExp :: Pattern -> Exp 257 | patToExp (PConstr v vs) = foldl EApp (EConstr v) (map patToExp vs) 258 | patToExp (PVar v) = EVar v 259 | patToExp (PLit x) = ELit x 260 | patToExp PWild = EVar "undefined" 261 | 262 | 263 | newtype TypeEnv = TypeEnv (M.Map String Scheme) 264 | 265 | remove :: Var -> TypeEnv -> TypeEnv 266 | remove var (TypeEnv env) = TypeEnv (M.delete var env) 267 | 268 | add :: Var -> Scheme -> TypeEnv -> TypeEnv 269 | add v sch (TypeEnv m) = TypeEnv (M.insert v sch m) 270 | 271 | instance Types TypeEnv where 272 | ftv (TypeEnv env) = ftv (M.elems env) 273 | apply s (TypeEnv env) = TypeEnv (M.map (apply s) env) 274 | 275 | generalize :: TypeEnv -> Type -> Scheme 276 | generalize env t = Scheme vars t 277 | where vars = S.toList (ftv t `S.difference` ftv env) 278 | 279 | instantiate :: Scheme -> TI Type 280 | instantiate (Scheme vars t) = do 281 | nvars <- mapM (\ _ -> newTyVar "a") vars 282 | let s = M.fromList (zip vars nvars) 283 | refresh (apply s t) 284 | 285 | 286 | -- Lookup a expression level variable in the environment 287 | lookupType :: TypeEnv -> String -> TI Type 288 | lookupType (TypeEnv m) v = case M.lookup v m of 289 | Nothing -> throwError $ "Undeclared variable " ++ v 290 | Just sch -> instantiate sch 291 | 292 | lookupType' :: TypeEnv -> String -> Scheme 293 | lookupType' (TypeEnv m) s = case (M.lookup s m) of 294 | Nothing -> throw $ TypeException $ "Undeclared variable: " ++ s 295 | Just sch -> sch 296 | 297 | declarePoly :: String -> Type -> TypeEnv -> TypeEnv 298 | declarePoly v t e = add v (generalize e t) e 299 | 300 | declareMono :: String -> Type -> TypeEnv -> TypeEnv 301 | declareMono v t = add v (Scheme [] t) 302 | -------------------------------------------------------------------------------- /TypeTest.hs: -------------------------------------------------------------------------------- 1 | module TypeTest where 2 | import TI 3 | import AST.DataTypes 4 | import Data.Map 5 | 6 | testTI = fst $ runTI $ do 7 | let t = TFun (TVar "b") (TApp (TConstr "[]") (TVar "b")) 8 | unify (TFun (TConstr "Int") (TVar "a")) t 9 | debugTI 10 | 11 | testExp :: Exp -> IO() 12 | testExp e = putStrLn $ testExpToString e 13 | where 14 | testExpToString :: Exp -> String 15 | testExpToString e = case runTI (infer (TypeEnv empty) e) of 16 | (Left error,_) -> show e ++ "\n-- ERROR: " ++ error ++ "\n" 17 | (Right t,_) -> show e ++ " :: " ++ show t ++ "\n" 18 | 19 | 20 | eZero = ELit (ILit 0) 21 | eOne = ELit (ILit 1) 22 | eTwo = ELit (ILit 2) 23 | eThree = ELit (ILit 3) 24 | eFour = ELit (ILit 4) 25 | eFive = ELit (ILit 5) 26 | eSix = ELit (ILit 6) 27 | eSeven = ELit (ILit 7) 28 | eEight = ELit (ILit 8) 29 | eNine = ELit (ILit 9) 30 | x = EVar "x" 31 | y = EVar "x" 32 | z = EVar "x" 33 | 34 | list0 = EApp 35 | (EConstr "Cons") 36 | eOne 37 | 38 | -- Cons 5 Nil -> [5] 39 | list1 = EApp 40 | (EApp 41 | (EConstr "Cons") 42 | eFive) 43 | (EConstr "Nil") 44 | 45 | -- Cons 5 (Cons 2 Nil) -> [5,2] 46 | list2 = EApp 47 | (EApp 48 | (EConstr "Cons") 49 | eFive) 50 | (EApp 51 | (EApp 52 | (EConstr "Cons") 53 | eTwo) 54 | (EConstr "Nil")) 55 | 56 | -- Cons 5 (Cons 2 (Cons 3 Nil)) -> [5,2,3] 57 | list3 = EApp 58 | (EApp 59 | (EConstr "Cons") 60 | eFive) 61 | (EApp 62 | (EApp 63 | (EConstr "Cons") 64 | eTwo) 65 | (EApp 66 | (EApp 67 | (EConstr "Cons") 68 | eThree) 69 | (EConstr "Nil"))) 70 | 71 | -- Cons 5 (Cons 2 (Cons 3 (Cons 1))) -> [5,2,3,1] 72 | list4 = EApp 73 | (EApp 74 | (EConstr "Cons") 75 | eFive) 76 | (EApp 77 | (EApp 78 | (EConstr "Cons") 79 | (ELit (CLit 'k'))) 80 | (EApp 81 | (EApp 82 | (EConstr "Cons") 83 | eThree) 84 | (EApp 85 | (EApp 86 | (EConstr "Cons") 87 | eOne) 88 | (EConstr "Nil")))) 89 | 90 | -- test expressions 91 | te1 = ELit $ ILit 3 92 | 93 | te2 = ELetIn "id" (ELam "x" (EVar "x")) 94 | (EVar "id") 95 | 96 | te3 = ELetIn "id" (ELam "x" (EVar "x")) 97 | (EApp (EVar "id") (EVar "id")) 98 | 99 | te4 = ELetIn "id" (ELam "x" (ELetIn "y" (EVar "x") (EVar "y"))) 100 | (EApp (EVar "id") (EVar "id")) 101 | 102 | te5 = ELetIn "id" (ELam "x" (ELetIn "y" (EVar "x") (EVar "y"))) 103 | (EApp (EApp (EVar "id") (EVar "id")) (ELit (ILit 2))) 104 | 105 | te6 = ELetIn "id" (ELam "x" (EApp (EVar "x") (EVar "x"))) 106 | (EVar "id") 107 | 108 | -- should Succeed 109 | te7 = ECase (ELit(ILit 2)) [(PLit(ILit 2), ELit(CLit 'i')) , 110 | (PLit(ILit 3), ELit(CLit 'u')) 111 | ] 112 | 113 | -- should Fail, different output types 114 | te8 = ECase (ELit(ILit 2)) [(PLit(ILit 2), ELit(CLit 'i')) , 115 | (PLit(ILit 6), ELit(ILit 9)) 116 | ] 117 | 118 | -- should Fail, different input and matching types 119 | te9 = ECase (ELit(CLit '2')) [(PLit(ILit 2), ELit(CLit 'i')) , 120 | (PLit(ILit 3), ELit(CLit 'u')) 121 | ] 122 | 123 | te10 = EConstr "True" 124 | 125 | te11 = EUnOp Not $ EConstr "False" 126 | 127 | --te12 = EApp (EVar "sum") list1 128 | -- where p1 = PConstr "Cons" ["x", "xs2"] 129 | -- e1 = EBinOp Add (EVar "x") 130 | -- (EApp (EVar "sum") (EVar "xs2")) 131 | -- p2 = PConstr "Nil" [] 132 | -- ecase = ECase (EVar "xs") [(p1, e1), (p2, eZero)] 133 | -- dSum = DFunc "sum" ["xs"] ecase 134 | 135 | main = do 136 | putStrLn "\n --- TESTING EXPRESSIONS --- \n\n" 137 | mapM_ testExp allTests 138 | where 139 | allTests = [te1,te2,te3,te4,te5,te6,te7,te8,te9,te10,te11] 140 | -------------------------------------------------------------------------------- /grammar/grammar.cf: -------------------------------------------------------------------------------- 1 | layout toplevel ; 2 | layout "of" ; 3 | 4 | -- A program is 0 or more imports followed by 5 | -- zero or more function declarations 6 | PFuncs. Program1 ::= Declaration Program1 ; 7 | PLast. Program1 ::= Declaration ; 8 | coercions Program 1 ; 9 | 10 | -- A declaration of function definitions, imports or algebraic data types 11 | DFunc. Declaration ::= "function" Id ":" Type ";" [Def] ; 12 | DData. Declaration ::= "datatype" TypeIdent [Id] ":=" [Constr] ";" ; 13 | separator nonempty Constr "|" ; 14 | DSyn. Declaration ::= "type" TypeIdent [Id] ":=" Type ";" ; 15 | layout toplevel ; 16 | 17 | -- Function definition 18 | DDef. Def ::= Id [Arg] ":=" Exp ; 19 | DGuardsDef. Def ::= Id [Arg] Guards ; 20 | terminator nonempty Def ";" ; 21 | 22 | DArg. Arg ::= Pattern ; 23 | separator Arg "" ; 24 | 25 | DConst1. Cons ::= "(" TypeId Id [Id] ")" ; 26 | DConst2. Cons ::= TypeId ; 27 | 28 | -- Structure of guards in function definitions 29 | DGuards1. Guards ::= ":=" Exp "when" Exp Guards1 ; 30 | DGuards2. Guards1 ::= ":=" Exp "when" Exp Guards1 ; 31 | DExpGuard. Guards1 ::= ":=" Exp ; 32 | DEmptyGuard. Guards1 ::= ; 33 | 34 | -- constructors for datatypes 35 | DConstr1. Constr ::= TypeIdent [TypeParameter] ; 36 | 37 | -- type parameter for constructors of datatypes 38 | TParameter. TypeParameter ::= Type2 ; 39 | separator TypeParameter "" ; 40 | 41 | -- Pattern matching 42 | PWild. Pattern1 ::= "_" ; 43 | PId. Pattern1 ::= Id ; 44 | PConstrEmp. Pattern1 ::= TypeId ; 45 | PLit. Pattern1 ::= Literal ; 46 | PEmpty. Pattern1 ::= "[]" ; 47 | PListPat. Pattern1 ::= "[" ListPat "]" ; 48 | PTuplePat. Pattern1 ::= "(" Pattern "," Pattern ")" ; 49 | PTruplePat. Pattern1 ::= "(" Pattern "," Pattern "," Pattern ")" ; 50 | PDataConstr. Pattern1 ::= "(" TypeIdent Pattern1 [Pattern1] ")" ; 51 | PCons. Pattern ::= Pattern1 ":" Pattern ; 52 | coercions Pattern 1 ; 53 | separator Pattern1 "" ; 54 | 55 | -- This is needed since the list definition below is space-separated 56 | -- for use in constructors 57 | PList1. ListPat ::= Pattern ; 58 | PList2. ListPat ::= Pattern "," ListPat ; 59 | 60 | []. [Pattern] ::= ; 61 | (:). [Pattern] ::= Pattern1 [Pattern] ; 62 | 63 | -- A literal can be any predefined token type 64 | LitInt. Literal ::= Integer ; 65 | LitDouble. Literal ::= Double ; 66 | LitChar. Literal ::= Char ; 67 | LitString. Literal ::= String ; 68 | separator nonempty Literal "," ; 69 | 70 | -- Tailor-made token type for type identifiers 71 | token TypeId upper (letter | digit | '_' | '\'')* ; 72 | separator nonempty TypeId "," ; 73 | 74 | -- Variable identifier token 75 | token Id lower (letter | digit | '_' | '\'')* ; 76 | separator Id "" ; 77 | 78 | -- Expression types 79 | EVar. Exp11 ::= Id ; 80 | ETuple. Exp11 ::= Tuple ; 81 | ELiteral. Exp11 ::= Literal ; 82 | EConst. Exp11 ::= Cons ; 83 | EList. Exp11 ::= "[" [Exp] "]" ; 84 | EEmptyList. Exp11 ::= "[]" ; 85 | EApp. Exp10 ::= Exp10 Exp11 ; 86 | ELogicalNeg. Exp9 ::= "not" Exp10 ; 87 | ENeg. Exp9 ::= "-" Exp10 ; 88 | EConcat. Exp9 ::= Exp9 "++" Exp10 ; 89 | ECons. Exp9 ::= Exp9 ":" Exp10 ; 90 | EPow. Exp8 ::= Exp8 "^" Exp9 ; 91 | EMul. Exp7 ::= Exp7 "*" Exp8 ; 92 | EDiv. Exp7 ::= Exp7 "/" Exp8 ; 93 | EAdd. Exp6 ::= Exp6 "+" Exp7 ; 94 | ESub. Exp6 ::= Exp6 "-" Exp7 ; 95 | ELt. Exp5 ::= Exp5 "<" Exp6 ; 96 | EGt. Exp5 ::= Exp5 ">" Exp6 ; 97 | ELEq. Exp5 ::= Exp5 "<=" Exp6 ; 98 | EGEq. Exp5 ::= Exp5 ">=" Exp6 ; 99 | EEq. Exp4 ::= Exp4 "==" Exp5 ; 100 | ENEq. Exp4 ::= Exp4 "!=" Exp5 ; 101 | EAnd. Exp3 ::= Exp3 "&&" Exp4 ; 102 | EOr. Exp2 ::= Exp2 "||" Exp3 ; 103 | ELet. Exp1 ::= "let" Id ":=" Exp2 "in" Exp ; 104 | EBind. Exp1 ::= Exp2 ">>=" Exp1 ; 105 | ESeq. Exp1 ::= Exp2 ">>" Exp1 ; 106 | ECase. Exp1 ::= "case" Exp "of" "{" Cases "}" ; 107 | EIf. Exp1 ::= "if" Exp2 "then" Exp2 "else" Exp ; 108 | EAbs. Exp1 ::= "\\" Id [Id] "->" Exp ; 109 | coercions Exp 11 ; 110 | separator Exp "," ; 111 | 112 | -- Structure for case expressions 113 | ECases1. Cases ::= Pattern "->" Exp ";" Cases1 ; 114 | ECases2. Cases1 ::= Pattern "->" Exp ";" Cases1 ; 115 | ECases3. Cases1 ::= Pattern "->" Exp ; 116 | 117 | --Fixed size tuples 118 | Tuple1. Tuple ::= "(" Exp "," Exp ")" ; 119 | Tuple2. Tuple ::= "(" Exp "," Exp "," Exp ")" ; 120 | 121 | -- Types, either regular or linear 122 | TypeIds. Type2 ::= TypeIdent ; 123 | TypeTuple. Type2 ::= "(" Type "," [Type] ")" ; 124 | TypeList. Type2 ::= "[" Type "]" ; 125 | TypeVoid. Type2 ::= "()" ; 126 | TypeDecl. Type1 ::= Type2 "->" Type1 ; 127 | LiTypeDecl. Type1 ::= Type2 "-o" Type1 ; 128 | TypeApp. Type ::= Type Type1 ; 129 | coercions Type 2 ; 130 | separator nonempty Type "," ; 131 | 132 | STypeIdent. TypeIdent ::= TypeId ; 133 | LiTypeIdent. TypeIdent ::= Id ; 134 | 135 | -- Haskell-style comments for now 136 | comment "--" ; 137 | comment "{-" "-}" ; 138 | -------------------------------------------------------------------------------- /grammar/testProgram.lp: -------------------------------------------------------------------------------- 1 | function putStrLn : Int ; 2 | putStrLn x := print x ; 3 | 4 | function testLam : Int -> Int ; 5 | testLam := (\y -> head y) (tail [1,2,3]) ; 6 | 7 | function sumFst : [(Int,Int)] -> Int ; 8 | sumFst (x:[]) := fst x ; 9 | sumFst (x:xs) := (fst x) + (sumFst xs) ; 10 | 11 | function sumFstList : [[Int]] -> Int ; 12 | sumFstList (x:[]) := head x ; 13 | sumFstList (x:xs) := (head x) + (sumFstList xs) ; 14 | 15 | function fst : [(Int,Int)] -> Int ; 16 | fst (x,y) := x ; 17 | 18 | function sum : [Int] -> Int ; 19 | sum (x:[]) := x ; 20 | sum (x:xs) := x + sum xs ; 21 | 22 | function head : [Int] -> Int ; 23 | head (x:[]) := x ; 24 | head (x:xs) := x ; 25 | 26 | function snd : [Int] -> Int ; 27 | snd (x:xs) := head xs ; 28 | 29 | function trd : [Int] -> Int ; 30 | trd (x:xs) := snd xs ; 31 | 32 | function tail : [Int] -> Int ; 33 | tail (x:[]) := x ; 34 | tail (x:xs) := xs ; 35 | 36 | function last : [Int] -> Int ; 37 | last y := case y of 38 | (x:[]) -> x 39 | (x:xs) -> last xs 40 | 41 | function lst : [Int] ; 42 | lst := [True,False,True] ; 43 | 44 | function tpl : (Int, Int) ; 45 | tpl := (1, 2) ; 46 | 47 | function bl : Bool ; 48 | bl := True ; 49 | 50 | function tpl2 : (Int, Int) -> Int ; 51 | tpl2 (1, 2) := 12 ; 52 | tpl2 (x, y) := x-y ; 53 | tpl2 (3, 4) := 34 ; 54 | 55 | function tpl3 : Int -> (Int, Int, Int) -> Int ; 56 | tpl3 x (3, y, 3) := 6-3 ; 57 | 58 | function one : Int ; 59 | one := 1 ; 60 | 61 | function pat : Int -> Int -> Int -> Int ; 62 | pat 0 x 2 := 5 ; 63 | pat 0 1 _ := 12 ; 64 | pat _ _ _ := 14 ; 65 | 66 | function patR : Int -> Int -> Int -> Int ; 67 | patR x 2 5 := x + 1 ; 68 | patR y 2 2 := 2 ; 69 | 70 | function grd : Int ; 71 | grd := 5 when True 72 | := 2 ; 73 | 74 | function useDbl : Int -> Int ; 75 | useDbl x := 4 + dbl x ; 76 | 77 | function dbl : Int -> Int ; 78 | dbl x := case x of 79 | 1 -> 2 80 | x -> 2 * x 81 | 82 | function ca : Int -> Int -> Int -> Int ; 83 | ca 3 x 2 := case x of 84 | 2 -> 2 + x 85 | _ -> 10 86 | ca _ 0 0 := 0 87 | 88 | function onePat : Int -> Int ; 89 | pat 2 := 11 ; 90 | pat _ := 0 ; 91 | 92 | --example from learnyouahaskell 93 | function zipWith : (a -> b -> c) -> [a] -> [b] -> [c] ; 94 | zipWith _ [] _ := [] ; 95 | zipWith _ _ [] := [] ; 96 | zipWith f (x:xs) (y:ys) := f x y : zipWith' f xs ys ; 97 | 98 | --type A := [(String,Int)] ; 99 | --type B := ([String] -> Int) -> Bool ; 100 | datatype Maybe a := Just a b | Nothing 101 | 102 | datatype Gender := Man a b | Woman Int | Frog 103 | 104 | datatype Cake a := Sweet a | Lie 105 | 106 | datatype Value := 107 | VIO (IO Value) -- void IO 108 | | VString String -- TODO Remove 109 | | VLit Lit 110 | | VConstr ConstrID [Value] -- list of values to be used as parameters 111 | | VFun (Value -> Value) 112 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/m0ar/lollipop/fffaf13b831b819b8e8a309468147874a8097727/logo.png -------------------------------------------------------------------------------- /loli.hs: -------------------------------------------------------------------------------- 1 | -- To play around a bit with your interpreter 2 | -- I wrote this little front end for the various 3 | -- parts of your program. 4 | -- to run : runghc -iAST/:grammar/ loli.hs 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | module Loli where 7 | 8 | import System.IO 9 | import AST.Interpreter 10 | import Converter hiding (main) 11 | import AST.DataTypes 12 | import AST.Environment 13 | import qualified AbsGrammar as A 14 | import TI 15 | import Control.Monad.State 16 | import Control.Monad.Except 17 | import Data.Maybe 18 | 19 | import LexGrammar 20 | import ParGrammar 21 | import LayoutGrammar 22 | import qualified AbsGrammar as G 23 | import ErrM 24 | import Control.Exception 25 | import Data.Typeable 26 | import Data.Either 27 | 28 | import Data.Map 29 | import qualified Data.Map as M 30 | 31 | import System.Environment as E 32 | 33 | myLLexer = resolveLayout True . myLexer 34 | 35 | main = do 36 | (pe,te) <- startSugarEnv 37 | E.getArgs >>= \s -> case s of 38 | [file] -> buildEnv pe te file >>= uncurry (repl file) 39 | [] -> repl "" pe te 40 | _ -> putStrLn "Invalid arguments" 41 | 42 | repl :: String -> Env -> TypeEnv -> IO () 43 | repl file env tEnv = do 44 | let loop = repl file env tEnv 45 | putStr (file ++ ">") >> hFlush stdout 46 | i <- getLine 47 | flip catch (\e -> print (e :: LoliException) >> loop) $ case i of 48 | "" -> loop 49 | ":q" -> return () 50 | ":r" -> buildEnv env tEnv file >>= uncurry (repl file) -- WOOOT 51 | (':':'t':' ':s) -> putStrLn (s ++ " : " ++ show (lookupType' tEnv s)) 52 | >> (repl file env tEnv) 53 | (':':'l':s) -> case words s of 54 | [newfile] -> do 55 | res <- try $ buildEnv env tEnv newfile 56 | case (res :: Either LoliException (Env, TypeEnv)) of 57 | Right (env, tEnv) -> repl newfile env tEnv 58 | Left err -> do putStrLn $ "\n" ++ show err ++ "\n" ++ newfile ++ " not loaded" 59 | repl "" env tEnv 60 | _ -> case pExp (myLexer i) of 61 | Bad s -> do putStrLn s 62 | loop 63 | Ok e -> case runTI (infer tEnv (cExp e)) of --empty env, replace with startTIEnv when implemented 64 | (Left error,_) -> do 65 | putStrLn "TYPE ERROR:" 66 | putStrLn $ error ++ " in expression: \n" ++ (show e) 67 | case eval env (cExp e) of --for testing, remove when startTIEnv implemented 68 | VIO io -> io >> loop 69 | _ -> loop 70 | (Right t,_) -> case eval env (cExp e) of 71 | VIO io -> io >> loop 72 | (VFun _) -> putStrLn "Invalid parameters for function" >> loop 73 | v -> print v >> loop 74 | 75 | 76 | buildEnv :: Env -> TypeEnv -> String -> IO (Env, TypeEnv) 77 | buildEnv progEnv tiEnv "" = do 78 | putStrLn "No file loaded" 79 | return (progEnv, tiEnv) 80 | buildEnv progEnv tiEnv file = do 81 | res <- try $ readFile (file ++ ".lp") 82 | case (res :: Either IOError String) of 83 | Right content -> do 84 | fc <- readFile (file ++ ".lp") 85 | prog <- let ts = (myLLexer fc) in case pProgram ts of 86 | Bad s -> do putStrLn s 87 | throw SyntaxError 88 | Ok tree -> return tree 89 | (sEnv, (TypeEnv sTEnv)) <- return (progEnv, tiEnv) 90 | let p@(Program ds fs) = cProgram prog 91 | env = addFuncDeclsToEnv env sEnv fs 92 | env' = addDataDeclsToEnv env ds 93 | (TypeEnv pTEnv) = progToTypeEnv p 94 | tEnv = M.union pTEnv sTEnv 95 | tiTypes = checkDecls p (TypeEnv tEnv) 96 | case getLefts tiTypes of 97 | [] -> putStrLn $ "\nSuccessfully loaded " ++ file 98 | s -> putStrLn $ "Type error: " ++ s 99 | return (env', (TypeEnv tEnv)) 100 | Left err -> do 101 | putStrLn "No such file, nothing loaded." 102 | throw NoSuchFile 103 | where 104 | getLefts :: [(String, TI Type)] -> String 105 | getLefts [] = [] 106 | getLefts ((s,t):xs) = if isLeft' res 107 | then "\n" ++ s ++ " : " ++ (replicate (20 - (length s)) ' ') ++ (either show show $ res) ++ getLefts xs 108 | else getLefts xs 109 | where res = fst (runTI t) 110 | 111 | -- Builds a starting type environment. 112 | tiStartEnv :: TypeEnv -> [(String, Value, Scheme)] -> TypeEnv 113 | tiStartEnv env [] = env 114 | tiStartEnv env ((a,b,c):xs) = tiStartEnv (add a c env) xs 115 | 116 | isRight' :: Either a b -> Bool 117 | isRight' (Right _) = True 118 | isRight' _ = False 119 | 120 | isLeft' :: Either a b -> Bool 121 | isLeft' (Left _) = True 122 | isLeft' _ = False 123 | 124 | -- Builds a starting environment with predefined functions and sugar. 125 | startSugarEnv :: IO (Env, TypeEnv) 126 | startSugarEnv = buildEnv startEnv (tiStartEnv (TypeEnv M.empty) startEnvironment) "sugar" 127 | 128 | checkDecls :: Program -> TypeEnv -> [(String, TI Type)] 129 | checkDecls p t = Prelude.map (checkDecl t) (getDFuncs p) 130 | where checkDecl :: TypeEnv -> FuncDecl -> (String, TI Type) 131 | checkDecl te d@(DFunc id t vs e) = (id, do 132 | --let es = error $ show $ Prelude.map getExp (getRhs p) 133 | let es' = Prelude.map getExp (getRhs d) 134 | let as = args e 135 | let linearOK = and $ Prelude.map (linCheck t te) (zip as es') 136 | r <- infer te e' 137 | case linearOK of 138 | False -> throw $ LinearException $ " Linear Check failed" 139 | True -> unify t r) 140 | where e' = Prelude.foldr ELam e vs 141 | 142 | 143 | linCheck :: Type -> TypeEnv -> ([Pattern], Exp) -> Bool 144 | linCheck t te (ps,e) = case isLinearType t of 145 | False -> True 146 | True -> let te' = bindLocalVars ps t te 147 | lEnv = initLocal M.empty ps 148 | in linearCheck lEnv te' e 149 | 150 | isLinearType :: Type -> Bool 151 | isLinearType t = case t of 152 | (TVar v) -> head v == 'i' 153 | (TiVar _) -> True 154 | (TConstr cid) -> head cid == 'i' 155 | (TiConstr _) -> True 156 | (TFun t1 t2) -> (isLinearType t1) || (isLinearType t2) 157 | (TApp t1 t2) -> (isLinearType t1) && (isLinearType t2) 158 | 159 | -- creates a local startenv inits all variables into it 160 | initLocal :: (M.Map Var Int) -> [Pattern] -> (M.Map Var Int) 161 | initLocal env [] = env 162 | initLocal env (p:ps) = case p of 163 | (PVar v) -> initLocal (M.insert v 0 env) ps 164 | (PConstr cid _) -> initLocal (M.insert cid 0 env) ps 165 | _ -> initLocal env ps 166 | 167 | 168 | -- returns the inner expression of a case-expression 169 | getExp :: Exp -> Exp 170 | getExp (ECase _ ((p,e):pes)) = getExp e 171 | getExp e = e 172 | 173 | args :: Exp -> [[Pattern]] 174 | args (ECase _ ((p,e):pes)) = (p:(args' e)):(concatMap args (snd $ unzip $ pes)) 175 | args _ = [] 176 | 177 | args' :: Exp -> [Pattern] 178 | args' (ECase _ []) = [] 179 | args' (ECase _ ((p,e):_)) = p:(args' e) 180 | args' _ = [] 181 | 182 | -- binds local variables to a type to use when checking linear type rules 183 | bindLocalVars :: [Pattern] -> Type -> TypeEnv -> TypeEnv 184 | bindLocalVars [] _ tEnv = tEnv 185 | bindLocalVars ((PVar v):ps) t tEnv = case t of 186 | (TFun t1 t2) -> bindLocalVars ps t2 (add v (Scheme [v] t1) tEnv) 187 | (TApp t1 t2) -> bindLocalVars ps t2 (add v (Scheme [v] t1) tEnv) 188 | t -> add v (Scheme [v] t) tEnv 189 | bindLocalVars ((PConstr cid ps'):ps) t tEnv = case t of 190 | (TFun t1 t2) -> bindLocalVars ps t2 (bindAll ps' t1 tEnv) 191 | (TApp t1 t2) -> bindLocalVars ps t2 (bindAll ps' t1 tEnv) 192 | t -> bindAll ps' t tEnv 193 | bindLocalVars (_:ps) t tEnv = case t of 194 | (TFun t1 t2) -> bindLocalVars ps t2 tEnv 195 | (TApp t1 t2) -> bindLocalVars ps t2 tEnv 196 | t -> error "internal error" 197 | 198 | -- binds all patterns to a definitive type 199 | bindAll :: [Pattern] -> Type -> TypeEnv -> TypeEnv 200 | bindAll [] _ te = te 201 | bindAll (p:ps) t te = case p of 202 | (PVar v) -> bindAll ps t (add v (Scheme [v] (TVar "a")) te) 203 | _ -> te 204 | 205 | -- returns all functions in a program 206 | getDFuncs :: Program -> [FuncDecl] 207 | getDFuncs (Program _ ds) = [d | d@(DFunc id t vs e) <- ds] 208 | 209 | -- returns all the right hand side expression of a program 210 | getRhs :: FuncDecl -> [Exp] 211 | getRhs (DFunc id t vs e) = case e of 212 | (ECase _ pes) -> [e' | (p,e') <- pes] 213 | _ -> [] 214 | -------------------------------------------------------------------------------- /sugar.lp: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------ 2 | -- DataTypes 3 | -- ------------------------------------------ 4 | 5 | -- Works like Haskells Maybe 6 | datatype Cake a := Sweet a | Lie 7 | -- either the cake is a Sweet or 8 | -- the cake is a lie 9 | 10 | function getCake : (Cake a) -> b 11 | getCake (Sweet x) := x 12 | getCake Lie := undefined 13 | 14 | datatype Boolean := True | False 15 | 16 | -- ------------------------------------------ 17 | 18 | -- misc functions 19 | function id : a -> a 20 | id x := x 21 | 22 | -- ------------------------------------------ 23 | -- Mathematical functions 24 | -- ------------------------------------------ 25 | 26 | -- The factorial function 27 | function fac : a -> b 28 | fac 0 := 1 29 | fac x := x * (fac (x-1)) 30 | 31 | -- Calculates the n:th Fibonacci number 32 | function fib : Int -> Int 33 | fib 0 := 0 34 | fib 1 := 1 35 | fib n := fib (n-2) + 36 | fib (n-1) 37 | 38 | -- Calculates the absolute value 39 | function abs : Int -> Int 40 | abs x 41 | := -x when x < 0 42 | := x 43 | 44 | -- Returns the "sign" for integers (1 for 45 | -- numbers >= 0 and -1 for numbers < 0) 46 | function sign : Int -> Int 47 | sign x 48 | := -1 when x < 0 49 | := 1 50 | 51 | -- Integer division 52 | function div : Int -> Int -> Int 53 | div _ 0 := undefined 54 | div 0 _ := 0 55 | div x y 56 | := div (-x) (-y) when y < 0 57 | := -1 + div (x+y) y when x < 0 58 | := 1 + div (x-y) y when x > y 59 | := 1 when x == y 60 | := 0 61 | 62 | -- Modulus 63 | function mod : Int -> Int -> Int 64 | mod x y := x - y * div x y 65 | 66 | -- Returns the successor of an integer 67 | function succ : Int -> Int 68 | succ x := x + 1 69 | 70 | -- Returns the predecessor of an integer 71 | function pred : Int -> Int 72 | pred x := x - 1 73 | 74 | -- Calculates the greatest common divisor 75 | -- of the two arguments 76 | function gcd : Int -> Int -> Int 77 | gcd x 0 := abs x 78 | gcd x y := gcd y (mod x y) 79 | 80 | -- Calculates the least common multiple 81 | -- of the two arguments 82 | function lcm : Int -> Int -> Int 83 | lcm 0 0 := 0 84 | lcm x y := div (abs (x*y)) (gcd x y) 85 | 86 | -- ------------------------------------------ 87 | -- Logical functions 88 | -- ------------------------------------------ 89 | 90 | -- Returns true if argument is odd 91 | function isOdd : Int -> Boolean 92 | isOdd x := mod x 2 == 1 93 | 94 | -- Returns true if argument is even 95 | function isEven : Int -> Boolean 96 | isEven x := mod x 2 == 0 97 | 98 | -- Checks if a list of Booleans only 99 | -- contains Trues 100 | function and : [Boolean] -> Boolean 101 | and xs := foldr (\x y -> x && y) True xs 102 | 103 | -- Checks if a list of Booleans contains 104 | -- any True 105 | function or : [Boolean] -> Boolean 106 | or xs := foldr (\x y -> x || y) False xs 107 | 108 | --- Check if any element of a list 109 | -- satisfies the predicate. 110 | function any : atoBoolean -> [a] -> Boolean 111 | any f xs := or (map f xs) 112 | 113 | -- Check if all element of a list 114 | -- satisfies the predicate. 115 | function all : atoBoolean -> [a] -> Boolean 116 | all f xs := and (map f xs) 117 | 118 | -- ------------------------------------------ 119 | -- Functions over tuples 120 | -- ------------------------------------------ 121 | 122 | -- Returns the first element in the tuple 123 | function fst : (a,b) -> a 124 | fst (x,y) := x 125 | 126 | -- -- Returns the second element in the tuple 127 | function snd : (a,b) -> b 128 | snd (x,y) := y 129 | 130 | -- Returns the maximum of the two elements 131 | -- in the tuple 132 | function max : (a,a) -> a 133 | max (x,y) 134 | := x when x > y 135 | := y 136 | 137 | -- Returns the minimum of the two elements 138 | -- in the tuple 139 | function min : (a,a) -> a 140 | min (x,y) 141 | := x when x < y 142 | := y 143 | 144 | -- ------------------------------------------ 145 | -- Functions over lists 146 | -- ------------------------------------------ 147 | 148 | -- Returns the first elements in the list 149 | function head : [a] -> a 150 | head [] := undefined 151 | head (x:xs) := x 152 | 153 | -- Returns the list of all elements except 154 | -- for the last in the input list 155 | function init : [a] -> [a] 156 | init [] := undefined 157 | init (x:[]) := [] 158 | init (x:xs) := x:(init xs) 159 | 160 | -- Returns the list of all elements except 161 | -- for the first in the input list 162 | function tail : [a] -> [a] 163 | tail [] := undefined 164 | tail (x:xs) := xs 165 | 166 | -- Returns the last elements in the list 167 | function last : [a] -> a 168 | last [] := undefined 169 | last (x:[]) := x 170 | last (x:xs) := last xs 171 | 172 | -- Returns the n first elements of the list 173 | function take : Int -> [a] -> [a] 174 | take n [] := [] 175 | take 0 _ := [] 176 | take n (x:xs) := x:(take (n-1) xs) 177 | 178 | -- Returns the list consisting of all elements 179 | -- that occur before the first element failing 180 | -- the predicate 181 | function takeWhile : (a -> Boolean) -> [a] -> [a] 182 | takeWhile _ [] := [] 183 | takeWhile f (x:xs) 184 | := (x:(takeWhile f xs)) when f x 185 | := [] 186 | 187 | -- Returns all except the n first elements of 188 | -- the list 189 | function drop : Int -> [a] -> [a] 190 | drop _ [] := [] 191 | drop 0 xs := xs 192 | drop n (x:xs) := drop (n-1) xs 193 | 194 | -- Returns the list consisting of all elements 195 | -- that occur after the first element failing 196 | -- the predicate (including that element) 197 | function dropWhile : (a -> Boolean) -> [a] -> [a] 198 | dropWhile _ [] := [] 199 | dropWhile f (x:xs) 200 | := dropWhile f xs when f x 201 | := (x:xs) 202 | 203 | -- Returns the length of the list 204 | function length : [a] -> Int 205 | length [] := 0 206 | length (x:xs) := 1 + length xs 207 | 208 | -- Returns the reversed list 209 | function reverse : [a] -> [a] 210 | reverse [] := [] 211 | reverse (x:xs) := reverse xs ++ [x] 212 | 213 | -- Returns true if the given value is an element 214 | -- in the list, otherwise false. 215 | -- function elem : [a] -> a -> Boolean 216 | -- elem xs := any (\x y -> x==y) xs 217 | 218 | -- Returns the sum of all elements of the list 219 | function sumList : [a] -> a 220 | sumList xs := foldr (\x y -> x+y) 0 xs 221 | 222 | -- Returns the greatest element of the list 223 | function maximum : [a] -> a 224 | maximum (x:[]) := x 225 | maximum (x:xs) 226 | := maximum xs when x < head xs 227 | := maximum (x:(tail xs)) 228 | 229 | -- Returns the smallest element of the list 230 | function minimum : [a] -> a 231 | minimum (x:[]) := x 232 | minimum (x:xs) 233 | := minimum xs when x > head xs 234 | := minimum (x:(tail xs)) 235 | 236 | -- Returns the elements satisfying the 237 | -- predicate 238 | function filter : atoBoolean -> [a] -> [a] 239 | filter _ [] := [] 240 | filter f (x:xs) 241 | := x:(filter f xs) when (f x) 242 | := filter f xs 243 | 244 | function concat : [a] -> [a] -> [a] 245 | concat [] ys := ys 246 | concat (x:xs) ys := x:(concat xs ys) 247 | 248 | function map : atob -> [a] -> [b] 249 | map f (x:xs) := (f x):(map f xs) 250 | map f [] := [] 251 | 252 | function foldr : atobtob -> b -> [a] -> b 253 | foldr _ b [] := b 254 | foldr f b (x:xs) := f x (foldr f b xs) 255 | 256 | -- Folds a list from the left 257 | function foldl : atobtob -> b -> [a] -> b 258 | foldl _ a [] := a 259 | foldl f a (x:xs) := foldl f (f a x) xs 260 | 261 | -- Zips together two lists to a list of tuples 262 | function zip : [a] -> [b] -> [(a,b)] 263 | zip [] _ := [] 264 | zip _ [] := [] 265 | zip (x:xs) (y:ys) := (x,y):(zip xs ys) 266 | 267 | -- Unzips a list of tuples to a tuple of lists 268 | function unzip : [(a,b)] -> ([a], [b]) 269 | unzip [] := ([], []) 270 | unzip ((x,y):xys) := ((x:(fst (unzip xys))), 271 | (y:(snd (unzip xys)))) 272 | 273 | -- Applies the function on the corresponding elements 274 | -- in the input lists and returns the list of the 275 | -- values returned by the function 276 | function zipWith : (a -> b -> c) -> [a] -> [b] -> [c] 277 | zipWith _ [] _ := [] 278 | zipWith _ _ [] := [] 279 | zipWith f (x:xs) (y:ys) := (f x y):(zipWith f xs ys) 280 | 281 | -- print takes a list of characters and calls printChar one every element 282 | function print : [Char] -> (IO Char) 283 | print [] := printChar '\n' 284 | print (c:cs) := printChar c >> print cs 285 | -------------------------------------------------------------------------------- /testLinear.lp: -------------------------------------------------------------------------------- 1 | function main : iInt -o Int 2 | main x := x + 6 + x 3 | -------------------------------------------------------------------------------- /testList.lp: -------------------------------------------------------------------------------- 1 | function empty : [Int] ; 2 | empty := [] ; 3 | 4 | function lst1 : [Bool] ; 5 | lst1 := [True,False,True] ; 6 | 7 | function head : [Int] -> Int ; 8 | head [] := 0 ; 9 | head (x:xs) := x ; 10 | 11 | function lstPat1 : [Int] -> Int ; 12 | lstPat1 ys := case ys of 13 | [] -> 0 ; 14 | (1:xs) -> 1 ; 15 | (x:[]) -> x ; 16 | (_:xs) -> 3 ; ; 17 | 18 | function lstPat2 : [Int] -> Int ; 19 | lstPat2 [] := 0 ; 20 | lstPat2 (1:xs) := 1 ; 21 | lstPat2 (x:[]) := x ; 22 | lstPat2 (_:xs) := 3 ; 23 | 24 | function sum : [Int] -> Int ; 25 | sum [] := 0 ; 26 | sum (x:xs) := x + sum xs ; 27 | 28 | function last : [Int] -> Int ; 29 | last ys := case ys of 30 | (x:[]) -> x ; 31 | (x:xs) -> last xs ;; 32 | 33 | 34 | -- Can't load file when these functions are included 35 | ---------------------------------------------------- 36 | {- 37 | 38 | -- list of ELiteral 39 | function lst2 : [Int] ; 40 | lst2 := [1,2,3] ; 41 | 42 | -- list of ETuple 43 | function lst3 : [Tuple] ; 44 | lst3 := [(1,2), (3,4)] ; 45 | 46 | -} -------------------------------------------------------------------------------- /testProgram.lp: -------------------------------------------------------------------------------- 1 | datatype Gender := Man a b | Woman Cake | Frog 2 | 3 | datatype D a := C (Cake a) 4 | 5 | -- overloading a f functions 6 | function id : Int 7 | id := 5 8 | 9 | function minz : IO 10 | minz (C x) := case x of 11 | (Sweet y) -> print "sweet y" 12 | Lie -> print "LIE" 13 | _ -> print "NADA" 14 | minz _ := print "gick inge bra" 15 | 16 | 17 | function testGen : Gender -> (IO Char) 18 | testGen Frog := print "hello" 19 | -- testGen x := case x of 20 | -- (Woman a) -> print "She's a lady" 21 | -- (Man a) -> print "Now, that's a man" 22 | -- (Frog a) -> print "A big frog" 23 | -- _ -> print "Something else" 24 | 25 | function testFoldl : Int 26 | testFoldl := foldl (\acc x -> acc + x) 0 27 | 28 | function addL : [Int] -> [Int] -> [Int] 29 | great x := x:[2,3,4] 30 | 31 | function great : Boolean 32 | great := 7 < 8 || 3 > 6 33 | 34 | function lett : Int 35 | lett := let x := pw 36 | in x + 2 37 | 38 | function nt : Boolean 39 | nt := not True 40 | 41 | function dv : Int 42 | dv := 5 + 2 43 | 44 | function pw : Int 45 | pw := 5 ^ (-2) 46 | 47 | function putStrLn : (IO Char) 48 | putStrLn := (print "hej" >> print " da, ") >> print " mamma" 49 | 50 | function testLam : [Int] -> Int 51 | testLam := (\y -> 2+(head y)) (tail [1,2,3]) 52 | 53 | function testLamMap : [Int] 54 | testLam := map (\x -> x+2) [1,2,3] 55 | 56 | function sumFst : [(Int,Int)] -> Int 57 | sumFst (x:[]) := fst x 58 | sumFst (x:xs) := (fst x) + (sumFst xs) 59 | 60 | function sumFstList : [[Int]] -> Int 61 | sumFstList (x:[]) := head x 62 | sumFstList (x:xs) := (head x) + (sumFstList xs) 63 | 64 | function fst : (Int,Int) -> Int 65 | fst (x,y) := x 66 | 67 | function sum : [Int] -> Int 68 | sum (x:[]) := x 69 | sum (x:xs) := x + sum xs 70 | 71 | function head : [Int] -> Int 72 | head (x:[]) := x 73 | head (x:xs) := x 74 | 75 | function trd : [Int] -> Int 76 | trd (x:xs) := head (tail xs) 77 | 78 | function tail : [Int] -> [Int] 79 | tail (x:[]) := x 80 | tail (x:xs) := xs 81 | 82 | function last : [Int] -> Int 83 | last y := case y of 84 | (x:[]) -> x 85 | (x:xs) -> last xs 86 | 87 | function lst : [Boolean] 88 | lst := [True,False,True] 89 | 90 | function tpl : (Int, Int) 91 | tpl := (1, 2) 92 | 93 | function bl : Boolean 94 | bl := True 95 | 96 | function tpl2 : (Int, Int) -> Int 97 | tpl2 (1, 2) := 12 98 | tpl2 (x, y) := x-y 99 | tpl2 (3, 4) := 34 100 | 101 | 102 | function one : (a,b) -> (b,a) 103 | one (x,y) := (y,x) 104 | 105 | function pat : Int -> Int -> Int -> Int 106 | pat 0 x 2 := 5 107 | pat 0 1 _ := 12 108 | pat _ _ _ := 14 109 | 110 | function patR : Int -> Int -> Int -> Int 111 | patR x 2 5 := x + 1 112 | patR y 2 2 := 2 113 | 114 | function grd : Boolean 115 | grd a b := True when a > b 116 | := False when a < b 117 | := False 118 | 119 | function useDbl : Int -> Int 120 | useDbl x := 4 + dbl x 121 | 122 | function dbl : Int -> Int 123 | dbl x := case x of 124 | 1 -> 2 125 | x -> 2 * x 126 | 127 | function linearError : Int -> Int -> iInt -o Int 128 | linearError x y z := x + y + z + x + y + z 129 | 130 | function ca : Int -> Int -> Int -> Int 131 | ca 3 x 2 := case x of 132 | 2 -> 2 + x 133 | _ -> 10 134 | ca _ 0 0 := 0 135 | 136 | function onePat : Int -> Int 137 | pat 2 := 11 138 | pat _ := 0 139 | 140 | function testMap : a 141 | testMap := map (print "x") [1,2,3] 142 | 143 | function naturals : [Int] 144 | naturals := cons 0 (map (\x -> x+1) naturals) 145 | 146 | -- Sum of first 100 naturals 147 | function main : Int 148 | main := foldr (\x y -> x + y) 0 (take 5 [1,2,3,4,5,6,7,8]) 149 | 150 | function testPat : Int -> [Int] -> [Int] 151 | testPat := pat 0 dv 2 152 | 153 | function lazy : Int 154 | lazy := oneFsc 5 infy 155 | 156 | function oneFsc : Int 157 | oneFsc x y := x 158 | 159 | function infy : Int 160 | infy := 1 + infy 161 | --------------------------------------------------------------------------------