yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make AST more general and try to give its phases better names

Browse source 
Also change the constructors for the Pattern ADT
This commit is contained in:
Evan Czaplicki 2014-02-10 00:17:33 +01:00
parent 594ed1988a
commit 9dd5dff279
34 changed files with 715 additions and 637 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
Elm.cabal
View file

@ -37,19 +37,19 @@ Library
Elm.Internal.Utils, Elm.Internal.Utils,
Elm.Internal.Version Elm.Internal.Version
Hs-Source-Dirs: compiler Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration, other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression, SourceSyntax.Expression,
SourceSyntax.Helpers, SourceSyntax.Helpers,
SourceSyntax.Literal, SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module, SourceSyntax.Module,
SourceSyntax.Pattern, SourceSyntax.Pattern,
SourceSyntax.PrettyPrint, SourceSyntax.PrettyPrint,
SourceSyntax.Type, SourceSyntax.Type,
SourceSyntax.Variable,
Generate.JavaScript, Generate.JavaScript,
Generate.JavaScript.Helpers, Generate.JavaScript.Helpers,
Generate.JavaScript.Ports, Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown, Generate.Markdown,
Generate.Html, Generate.Html,
Generate.Cases, Generate.Cases,
@ -119,19 +119,19 @@ Executable elm
Main-is: Compiler.hs Main-is: Compiler.hs
ghc-options: -threaded -O2 ghc-options: -threaded -O2
Hs-Source-Dirs: compiler Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration, other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression, SourceSyntax.Expression,
SourceSyntax.Helpers, SourceSyntax.Helpers,
SourceSyntax.Literal, SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module, SourceSyntax.Module,
SourceSyntax.Pattern, SourceSyntax.Pattern,
SourceSyntax.PrettyPrint, SourceSyntax.PrettyPrint,
SourceSyntax.Type, SourceSyntax.Type,
SourceSyntax.Variable,
Generate.JavaScript, Generate.JavaScript,
Generate.JavaScript.Helpers, Generate.JavaScript.Helpers,
Generate.JavaScript.Ports, Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown, Generate.Markdown,
Generate.Html, Generate.Html,
Generate.Cases, Generate.Cases,
@ -200,15 +200,16 @@ Executable elm
Executable elm-doc Executable elm-doc
Main-is: Docs.hs Main-is: Docs.hs
Hs-Source-Dirs: compiler Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration, other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression, SourceSyntax.Expression,
SourceSyntax.Helpers, SourceSyntax.Helpers,
SourceSyntax.Literal, SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module, SourceSyntax.Module,
SourceSyntax.Pattern, SourceSyntax.Pattern,
SourceSyntax.PrettyPrint, SourceSyntax.PrettyPrint,
SourceSyntax.Type, SourceSyntax.Type,
SourceSyntax.Variable,
Parse.Binop, Parse.Binop,
Parse.Declaration, Parse.Declaration,
Parse.Expression, Parse.Expression,

63
compiler/Generate/Cases.hs
View file

@ -6,14 +6,15 @@ import Control.Monad.State
import Data.List (groupBy,sortBy) import Data.List (groupBy,sortBy)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import SourceSyntax.Location import SourceSyntax.Annotation
import SourceSyntax.Literal
import SourceSyntax.Pattern
import SourceSyntax.Expression import SourceSyntax.Expression
import SourceSyntax.Literal
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as V
import Transform.Substitute import Transform.Substitute
toMatch :: [(Pattern, LExpr)] -> State Int (String, Match) toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
toMatch patterns = do toMatch patterns = do
v <- newVar v <- newVar
(,) v <$> match [v] (map (first (:[])) patterns) Fail (,) v <$> match [v] (map (first (:[])) patterns) Fail
@ -27,7 +28,7 @@ data Match
= Match String [Clause] Match = Match String [Clause] Match
| Break | Break
| Fail | Fail
| Other LExpr | Other Expr
| Seq [Match] | Seq [Match]
deriving Show deriving Show
@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
matchSubst _ Break = Break matchSubst _ Break = Break
matchSubst _ Fail = Fail matchSubst _ Fail = Fail
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms) matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
matchSubst pairs (Other (L s e)) = matchSubst pairs (Other (A a e)) =
Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
matchSubst pairs (Match n cs m) = matchSubst pairs (Match n cs m) =
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m) Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
where varSubst v = fromMaybe v (lookup v pairs) where varSubst v = fromMaybe v (lookup v pairs)
@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
isCon (p:_, _) = isCon (p:_, _) =
case p of case p of
PData _ _ -> True P.Data _ _ -> True
PLiteral _ -> True P.Literal _ -> True
_ -> False _ -> False
isVar p = not (isCon p) isVar p = not (isCon p)
match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
match [] [] def = return def match [] [] def = return def
match [] [([],e)] Fail = return $ Other e match [] [([],e)] Fail = return $ Other e
match [] [([],e)] Break = return $ Other e match [] [([],e)] Break = return $ Other e
@ -67,46 +68,46 @@ match vs@(v:_) cs def
where where
cs' = map (dealias v) cs cs' = map (dealias v) cs
dealias v c@(p:ps, L s e) = dealias v c@(p:ps, A a e) =
case p of case p of
PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e) P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
_ -> c _ -> c
matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchVar (v:vs) cs def = match vs (map subVar cs) def matchVar (v:vs) cs def = match vs (map subVar cs) def
where where
subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e) subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
where where
subOnePattern pattern e = subOnePattern pattern e =
case pattern of case pattern of
PVar x -> subst x (Var v) e P.Var x -> subst x (rawVar v) e
PAnything -> e P.Anything -> e
PRecord fs -> P.Record fs ->
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
where where
css = groupBy eq (sortBy cmp cs) css = groupBy eq (sortBy cmp cs)
cmp (p1:_,_) (p2:_,_) = cmp (p1:_,_) (p2:_,_) =
case (p1,p2) of case (p1,p2) of
(PData n1 _, PData n2 _) -> compare n1 n2 (P.Data n1 _, P.Data n2 _) -> compare n1 n2
_ -> compare p1 p2 _ -> compare p1 p2
eq (p1:_,_) (p2:_,_) = eq (p1:_,_) (p2:_,_) =
case (p1,p2) of case (p1,p2) of
(PData n1 _, PData n2 _) -> n1 == n2 (P.Data n1 _, P.Data n2 _) -> n1 == n2
_ -> p1 == p2 _ -> p1 == p2
toClause cs = toClause cs =
case head cs of case head cs of
(PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
(PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
matchClause :: Either String Literal matchClause :: Either String Literal
-> [String] -> [String]
-> [([Pattern],LExpr)] -> [([P.Pattern],Expr)]
-> Match -> Match
-> State Int Clause -> State Int Clause
matchClause c (_:vs) cs def = matchClause c (_:vs) cs def =
@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
flatten (p:ps, e) = flatten (p:ps, e) =
case p of case p of
PData _ ps' -> (ps' ++ ps, e) P.Data _ ps' -> (ps' ++ ps, e)
PLiteral _ -> (ps, e) P.Literal _ -> (ps, e)
getVars = getVars =
case head cs of case head cs of
(PData _ ps : _, _) -> forM ps (const newVar) (P.Data _ ps : _, _) -> forM ps (const newVar)
(PLiteral _ : _, _) -> return [] (P.Literal _ : _, _) -> return []
matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchMix vs cs def = foldM (flip $ match vs) def (reverse css) matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

99
compiler/Generate/JavaScript.hs
View file

@ -1,25 +1,27 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Generate.JavaScript (generate) where module Generate.JavaScript (generate) where
import Control.Arrow (first,(***))
import Control.Applicative ((<$>),(<*>)) import Control.Applicative ((<$>),(<*>))
import Control.Arrow (first,(***))
import Control.Monad.State import Control.Monad.State
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Language.ECMAScript3.PrettyPrint
import Language.ECMAScript3.Syntax
import Generate.JavaScript.Helpers import Generate.JavaScript.Helpers
import qualified Generate.Cases as Case import qualified Generate.Cases as Case
import qualified Generate.JavaScript.Ports as Port import qualified Generate.JavaScript.Ports as Port
import qualified Generate.Markdown as MD import qualified Generate.Markdown as MD
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Helpers as Help import qualified SourceSyntax.Helpers as Help
import SourceSyntax.Literal import SourceSyntax.Literal
import SourceSyntax.Pattern as Pattern
import SourceSyntax.Location
import SourceSyntax.Expression
import SourceSyntax.Module import SourceSyntax.Module
import Language.ECMAScript3.Syntax import qualified SourceSyntax.Pattern as P
import Language.ECMAScript3.PrettyPrint import SourceSyntax.PrettyPrint (renderPretty)
import qualified SourceSyntax.Variable as V
import qualified Transform.SafeNames as MakeSafe import qualified Transform.SafeNames as MakeSafe
varDecl :: String -> Expression () -> VarDecl () varDecl :: String -> Expression () -> VarDecl ()
@ -50,10 +52,10 @@ literal lit =
FloatNum n -> NumLit () n FloatNum n -> NumLit () n
Boolean b -> BoolLit () b Boolean b -> BoolLit () b
expression :: LExpr -> State Int (Expression ()) expression :: Expr -> State Int (Expression ())
expression (L span expr) = expression (A region expr) =
case expr of case expr of
Var x -> return $ ref x Var (V.Raw x) -> return $ ref x
Literal lit -> return $ literal lit Literal lit -> return $ literal lit
Range lo hi -> Range lo hi ->
@ -93,9 +95,9 @@ expression (L span expr) =
Map.toList . Map.filter (not . null) $ Map.map tail fs Map.toList . Map.filter (not . null) $ Map.map tail fs
visible fs = map (first prop) . Map.toList $ Map.map head fs visible fs = map (first prop) . Map.toList $ Map.map head fs
Binop op e1 e2 -> binop span op e1 e2 Binop op e1 e2 -> binop region op e1 e2
Lambda p e@(L s _) -> Lambda p e@(A ann _) ->
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns) do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
body' <- expression body body' <- expression body
return $ case length args < 2 || length args > 9 of return $ case length args < 2 || length args > 9 of
@ -104,13 +106,14 @@ expression (L span expr) =
where where
depattern (args, body) pattern = depattern (args, body) pattern =
case pattern of case pattern of
PVar x -> return (args ++ [x], body) P.Var x -> return (args ++ [x], body)
_ -> do arg <- Case.newVar _ -> do arg <- Case.newVar
return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)])) return ( args ++ [arg]
, A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
(patterns, innerBody) = collect [p] e (patterns, innerBody) = collect [p] e
collect patterns lexpr@(L _ expr) = collect patterns lexpr@(A _ expr) =
case expr of case expr of
Lambda p e -> collect (p:patterns) e Lambda p e -> collect (p:patterns) e
_ -> (patterns, lexpr) _ -> (patterns, lexpr)
@ -127,7 +130,7 @@ expression (L span expr) =
(func, args) = getArgs e1 [e2] (func, args) = getArgs e1 [e2]
getArgs func args = getArgs func args =
case func of case func of
(L _ (App f arg)) -> getArgs f (arg : args) (A _ (App f arg)) -> getArgs f (arg : args)
_ -> (func, args) _ -> (func, args)
Let defs e -> Let defs e ->
@ -139,9 +142,9 @@ expression (L span expr) =
MultiIf branches -> MultiIf branches ->
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
return $ case last branches of return $ case last branches of
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches' (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
(L _ (Literal (Boolean True)), _) -> safeIfs branches' (A _ (Literal (Boolean True)), _) -> safeIfs branches'
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ]) _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
where where
safeIfs branches = ifs (init branches) (snd (last branches)) safeIfs branches = ifs (init branches) (snd (last branches))
ifs branches finally = foldr iff finally branches ifs branches finally = foldr iff finally branches
@ -151,10 +154,12 @@ expression (L span expr) =
do (tempVar,initialMatch) <- Case.toMatch cases do (tempVar,initialMatch) <- Case.toMatch cases
(revisedMatch, stmt) <- (revisedMatch, stmt) <-
case e of case e of
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, []) A _ (Var (V.Raw x)) ->
_ -> do e' <- expression e return (Case.matchSubst [(tempVar,x)] initialMatch, [])
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']]) _ ->
match' <- match span revisedMatch do e' <- expression e
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
match' <- match region revisedMatch
return (function [] (stmt ++ match') `call` []) return (function [] (stmt ++ match') `call` [])
ExplicitList es -> ExplicitList es ->
@ -184,28 +189,28 @@ expression (L span expr) =
[ string name, Port.outgoing tipe, value' ] [ string name, Port.outgoing tipe, value' ]
definition :: Def -> State Int [Statement ()] definition :: Def -> State Int [Statement ()]
definition (Definition pattern expr@(L span _) _) = do definition (Definition pattern expr@(A region _) _) = do
expr' <- expression expr expr' <- expression expr
let assign x = varDecl x expr' let assign x = varDecl x expr'
case pattern of case pattern of
PVar x P.Var x
| Help.isOp x -> | Help.isOp x ->
let op = LBracket () (ref "_op") (string x) in let op = LBracket () (ref "_op") (string x) in
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ] return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
| otherwise -> | otherwise ->
return [ VarDeclStmt () [ assign x ] ] return [ VarDeclStmt () [ assign x ] ]
PRecord fields -> P.Record fields ->
let setField f = varDecl f (dotSep ["$",f]) in let setField f = varDecl f (dotSep ["$",f]) in
return [ VarDeclStmt () (assign "$" : map setField fields) ] return [ VarDeclStmt () (assign "$" : map setField fields) ]
PData name patterns | vars /= Nothing -> P.Data name patterns | vars /= Nothing ->
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ] return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
where where
vars = getVars patterns vars = getVars patterns
getVars patterns = getVars patterns =
case patterns of case patterns of
PVar x : rest -> (x:) `fmap` getVars rest P.Var x : rest -> (x:) `fmap` getVars rest
[] -> Just [] [] -> Just []
_ -> Nothing _ -> Nothing
@ -216,23 +221,23 @@ definition (Definition pattern expr@(L span _) _) = do
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception) safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name) if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)] exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
_ -> _ ->
do defs' <- concat <$> mapM toDef vars do defs' <- concat <$> mapM toDef vars
return (VarDeclStmt () [assign "$"] : defs') return (VarDeclStmt () [assign "$"] : defs')
where where
vars = Set.toList $ Pattern.boundVars pattern vars = P.boundVarList pattern
mkVar = L span . Var mkVar = A region . rawVar
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)] toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (PVar y) expr Nothing in definition $ Definition (P.Var y) expr Nothing
match :: SrcSpan -> Case.Match -> State Int [Statement ()] match :: Region -> Case.Match -> State Int [Statement ()]
match span mtch = match region mtch =
case mtch of case mtch of
Case.Match name clauses mtch' -> Case.Match name clauses mtch' ->
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
mtch'' <- match span mtch' mtch'' <- match region mtch'
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'') return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
where where
isLiteral p = case p of isLiteral p = case p of
@ -244,13 +249,13 @@ match span mtch =
| otherwise = e | otherwise = e
Case.Fail -> Case.Fail ->
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ] return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
Case.Break -> return [BreakStmt () Nothing] Case.Break -> return [BreakStmt () Nothing]
Case.Other e -> Case.Other e ->
do e' <- expression e do e' <- expression e
return [ ret e' ] return [ ret e' ]
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms) Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
where where
dropEnd acc [] = acc dropEnd acc [] = acc
dropEnd acc (m:ms) = dropEnd acc (m:ms) =
@ -258,9 +263,9 @@ match span mtch =
Case.Other _ -> acc ++ [m] Case.Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms _ -> dropEnd (acc ++ [m]) ms
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ()) clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause span variable (Case.Clause value vars mtch) = clause region variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch) (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
where where
vars' = map (\n -> variable ++ "._" ++ show n) [0..] vars' = map (\n -> variable ++ "._" ++ show n) [0..]
(isChar, pattern) = (isChar, pattern) =
@ -273,8 +278,8 @@ clause span variable (Case.Clause value vars mtch) =
[] -> name [] -> name
is -> drop (last is + 1) name is -> drop (last is + 1) name
flattenLets :: [Def] -> LExpr -> ([Def], LExpr) flattenLets :: [Def] -> Expr -> ([Def], Expr)
flattenLets defs lexpr@(L _ expr) = flattenLets defs lexpr@(A _ expr) =
case expr of case expr of
Let ds body -> flattenLets (defs ++ ds) body Let ds body -> flattenLets (defs ++ ds) body
_ -> (defs, lexpr) _ -> (defs, lexpr)
@ -321,8 +326,8 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path Just nmspc -> drop 2 . init . List.inits $ nmspc : path
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ()) binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
binop span op e1 e2 = binop region op e1 e2 =
case op of case op of
"Basics.." -> "Basics.." ->
do es <- mapM expression (e1 : collect [] e2) do es <- mapM expression (e1 : collect [] e2)
@ -335,7 +340,7 @@ binop span op e1 e2 =
do e1' <- expression e1 do e1' <- expression e1
e2' <- expression e2 e2' <- expression e2
return $ obj "_L.append" `call` [e1', e2'] return $ obj "_L.append" `call` [e1', e2']
"::" -> expression (L span (Data "::" [e1,e2])) "::" -> expression (A region (Data "::" [e1,e2]))
_ -> _ ->
do e1' <- expression e1 do e1' <- expression e1
e2' <- expression e2 e2' <- expression e2
@ -345,7 +350,7 @@ binop span op e1 e2 =
where where
collect es e = collect es e =
case e of case e of
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
_ -> es ++ [e] _ -> es ++ [e]
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator) func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

33
compiler/Parse/Binop.hs
View file

@ -1,10 +1,11 @@
{-# OPTIONS_GHC -W #-}
module Parse.Binop (binops, OpTable) where module Parse.Binop (binops, OpTable) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.List (intercalate) import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import SourceSyntax.Location (merge) import SourceSyntax.Annotation (merge)
import qualified SourceSyntax.Expression as E import qualified SourceSyntax.Expression as E
import SourceSyntax.Declaration (Assoc(..)) import SourceSyntax.Declaration (Assoc(..))
import Text.Parsec import Text.Parsec
@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
opAssoc :: OpTable -> String -> Assoc opAssoc :: OpTable -> String -> Assoc
opAssoc table op = snd $ Map.findWithDefault (9,L) op table opAssoc table op = snd $ Map.findWithDefault (9,L) op table
hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
hasLevel table n (op,_) = opLevel table op == n hasLevel table n (op,_) = opLevel table op == n
binops :: IParser E.LParseExpr binops :: IParser E.ParseExpr
-> IParser E.LParseExpr -> IParser E.ParseExpr
-> IParser String -> IParser String
-> IParser E.LParseExpr -> IParser E.ParseExpr
binops term last anyOp = binops term last anyOp =
do e <- term do e <- term
table <- getState table <- getState
@ -38,9 +39,9 @@ binops term last anyOp =
split :: OpTable split :: OpTable
-> Int -> Int
-> E.LParseExpr -> E.ParseExpr
-> [(String, E.LParseExpr)] -> [(String, E.ParseExpr)]
-> IParser E.LParseExpr -> IParser E.ParseExpr
split _ _ e [] = return e split _ _ e [] = return e
split table n e eops = do split table n e eops = do
assoc <- getAssoc table n eops assoc <- getAssoc table n eops
@ -49,26 +50,26 @@ split table n e eops = do
case assoc of R -> joinR es ops case assoc of R -> joinR es ops
_ -> joinL es ops _ -> joinL es ops
splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)] splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
-> [IParser E.LParseExpr] -> [IParser E.ParseExpr]
splitLevel table n e eops = splitLevel table n e eops =
case break (hasLevel table n) eops of case break (hasLevel table n) eops of
(lops, (op,e'):rops) -> (lops, (_op,e'):rops) ->
split table (n+1) e lops : splitLevel table n e' rops split table (n+1) e lops : splitLevel table n e' rops
(lops, []) -> [ split table (n+1) e lops ] (lops, []) -> [ split table (n+1) e lops ]
joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
joinL [e] [] = return e joinL [e] [] = return e
joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug." joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
joinR [e] [] = return e joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
return (merge a e (E.Binop op a e)) return (merge a e (E.Binop op a e))
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug." joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
getAssoc table n eops getAssoc table n eops
| all (==L) assocs = return L | all (==L) assocs = return L
| all (==R) assocs = return R | all (==R) assocs = return R
@ -79,5 +80,5 @@ getAssoc table n eops
assocs = map (opAssoc table . fst) levelOps assocs = map (opAssoc table . fst) levelOps
msg problem = msg problem =
concat [ "Conflicting " ++ problem ++ " for binary operators (" concat [ "Conflicting " ++ problem ++ " for binary operators ("
, intercalate ", " (map fst eops), "). " , List.intercalate ", " (map fst eops), "). "
, "Consider adding parentheses to disambiguate." ] , "Consider adding parentheses to disambiguate." ]

133
compiler/Parse/Expression.hs
View file

@ -5,45 +5,45 @@ import Data.List (foldl')
import Text.Parsec hiding (newline,spaces) import Text.Parsec hiding (newline,spaces)
import Text.Parsec.Indent import Text.Parsec.Indent
import Parse.Binop
import Parse.Helpers import Parse.Helpers
import Parse.Literal
import qualified Parse.Pattern as Pattern import qualified Parse.Pattern as Pattern
import qualified Parse.Type as Type import qualified Parse.Type as Type
import Parse.Binop
import Parse.Literal
import SourceSyntax.Location as Location import SourceSyntax.Annotation as Annotation
import SourceSyntax.Pattern hiding (tuple,list) import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Literal as Literal import qualified SourceSyntax.Literal as L
import SourceSyntax.Expression import SourceSyntax.Expression
-------- Basic Terms -------- -------- Basic Terms --------
varTerm :: IParser ParseExpr varTerm :: IParser ParseExpr'
varTerm = toVar <$> var <?> "variable" varTerm = toVar <$> var <?> "variable"
toVar :: String -> ParseExpr toVar :: String -> ParseExpr'
toVar v = case v of "True" -> Literal (Literal.Boolean True) toVar v = case v of "True" -> Literal (L.Boolean True)
"False" -> Literal (Literal.Boolean False) "False" -> Literal (L.Boolean False)
_ -> Var v _ -> rawVar v
accessor :: IParser ParseExpr accessor :: IParser ParseExpr'
accessor = do accessor = do
(start, lbl, end) <- located (try (string "." >> rLabel)) (start, lbl, end) <- located (try (string "." >> rLabel))
let loc e = Location.at start end e let loc e = Annotation.at start end e
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl)) return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
negative :: IParser ParseExpr negative :: IParser ParseExpr'
negative = do negative = do
(start, nTerm, end) <- (start, nTerm, end) <-
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term) located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
let loc e = Location.at start end e let loc e = Annotation.at start end e
return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm) return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
-------- Complex Terms -------- -------- Complex Terms --------
listTerm :: IParser ParseExpr listTerm :: IParser ParseExpr'
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr) listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
where where
range = do range = do
@ -66,86 +66,87 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
string "}}" string "}}"
return (span uid (length exprs), exprs ++ [e]) return (span uid (length exprs), exprs ++ [e])
parensTerm :: IParser LParseExpr parensTerm :: IParser ParseExpr
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened) parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
where where
opFn = do opFn = do
(start, op, end) <- located anyOp (start, op, end) <- located anyOp
let loc = Location.at start end let loc = Annotation.at start end
return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
Binop op (loc $ Var "x") (loc $ Var "y") Binop op (loc $ rawVar "x") (loc $ rawVar "y")
tupleFn = do tupleFn = do
let comma = char ',' <?> "comma ','" let comma = char ',' <?> "comma ','"
(start, commas, end) <- located (comma >> many (whitespace >> comma)) (start, commas, end) <- located (comma >> many (whitespace >> comma))
let vars = map (('v':) . show) [ 0 .. length commas + 1 ] let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
loc = Location.at start end loc = Annotation.at start end
return $ foldr (\x e -> loc $ Lambda x e) return $ foldr (\x e -> loc $ Lambda x e)
(loc . tuple $ map (loc . Var) vars) (map PVar vars) (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
parened = do parened = do
(start, es, end) <- located (commaSep expr) (start, es, end) <- located (commaSep expr)
return $ case es of return $ case es of
[e] -> e [e] -> e
_ -> Location.at start end (tuple es) _ -> Annotation.at start end (tuple es)
recordTerm :: IParser LParseExpr recordTerm :: IParser ParseExpr
recordTerm = brackets $ choice [ misc, addLocation record ] recordTerm = brackets $ choice [ misc, addLocation record ]
where field = do where
label <- rLabel field = do
patterns <- spacePrefix Pattern.term label <- rLabel
padded equals patterns <- spacePrefix Pattern.term
body <- expr padded equals
return (label, makeFunction patterns body) body <- expr
return (label, makeFunction patterns body)
record = Record <$> commaSep field record = Record <$> commaSep field
change = do change = do
lbl <- rLabel lbl <- rLabel
padded (string "<-") padded (string "<-")
(,) lbl <$> expr (,) lbl <$> expr
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel) remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
insert r = addLocation $ do insert r = addLocation $ do
string "|" >> whitespace string "|" >> whitespace
Insert r <$> rLabel <*> (padded equals >> expr) Insert r <$> rLabel <*> (padded equals >> expr)
modify r = addLocation modify r =
(string "|" >> whitespace >> Modify r <$> commaSep1 change) addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
misc = try $ do misc = try $ do
record <- addLocation (Var <$> rLabel) record <- addLocation (rawVar <$> rLabel)
opt <- padded (optionMaybe (remove record)) opt <- padded (optionMaybe (remove record))
case opt of case opt of
Just e -> try (insert e) <|> return e Just e -> try (insert e) <|> return e
Nothing -> try (insert record) <|> try (modify record) Nothing -> try (insert record) <|> try (modify record)
term :: IParser LParseExpr term :: IParser ParseExpr
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ]) term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm) <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
<?> "basic term (4, x, 'c', etc.)" <?> "basic term (4, x, 'c', etc.)"
-------- Applications -------- -------- Applications --------
appExpr :: IParser LParseExpr appExpr :: IParser ParseExpr
appExpr = do appExpr = do
t <- term t <- term
ts <- constrainedSpacePrefix term $ \str -> ts <- constrainedSpacePrefix term $ \str ->
if null str then notFollowedBy (char '-') else return () if null str then notFollowedBy (char '-') else return ()
return $ case ts of return $ case ts of
[] -> t [] -> t
_ -> foldl' (\f x -> Location.merge f x $ App f x) t ts _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
-------- Normal Expressions -------- -------- Normal Expressions --------
binaryExpr :: IParser LParseExpr binaryExpr :: IParser ParseExpr
binaryExpr = binops appExpr lastExpr anyOp binaryExpr = binops appExpr lastExpr anyOp
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ]) where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr <|> lambdaExpr
ifExpr :: IParser ParseExpr ifExpr :: IParser ParseExpr'
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf) ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
where where
normal = do normal = do
@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
elseBranch <- expr elseBranch <- expr
return $ MultiIf [(bool, thenBranch), return $ MultiIf [(bool, thenBranch),
(Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)] (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
multiIf = MultiIf <$> spaceSep1 iff multiIf = MultiIf <$> spaceSep1 iff
where iff = do string "|" ; whitespace where iff = do string "|" ; whitespace
b <- expr ; padded arrow b <- expr ; padded arrow
(,) b <$> expr (,) b <$> expr
lambdaExpr :: IParser LParseExpr lambdaExpr :: IParser ParseExpr
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function" lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
whitespace whitespace
args <- spaceSep1 Pattern.term args <- spaceSep1 Pattern.term
@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
defSet :: IParser [ParseDef] defSet :: IParser [ParseDef]
defSet = block (do d <- def ; whitespace ; return d) defSet = block (do d <- def ; whitespace ; return d)
letExpr :: IParser ParseExpr letExpr :: IParser ParseExpr'
letExpr = do letExpr = do
reserved "let" ; whitespace reserved "let" ; whitespace
defs <- defSet defs <- defSet
padded (reserved "in") padded (reserved "in")
Let defs <$> expr Let defs <$> expr
caseExpr :: IParser ParseExpr caseExpr :: IParser ParseExpr'
caseExpr = do caseExpr = do
reserved "case"; e <- padded expr; reserved "of"; whitespace reserved "case"; e <- padded expr; reserved "of"; whitespace
Case e <$> (with <|> without) Case e <$> (with <|> without)
@ -189,35 +190,35 @@ caseExpr = do
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }")) with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
without = block (do c <- case_ ; whitespace ; return c) without = block (do c <- case_ ; whitespace ; return c)
expr :: IParser LParseExpr expr :: IParser ParseExpr
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ]) expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr <|> lambdaExpr
<|> binaryExpr <|> binaryExpr
<?> "an expression" <?> "an expression"
defStart :: IParser [Pattern] defStart :: IParser [P.Pattern]
defStart = defStart =
choice [ do p1 <- try Pattern.term choice [ do p1 <- try Pattern.term
infics p1 <|> func p1 infics p1 <|> func p1
, func =<< (PVar <$> parens symOp) , func =<< (P.Var <$> parens symOp)
, (:[]) <$> Pattern.expr , (:[]) <$> Pattern.expr
] <?> "the definition of a variable (x = ...)" ] <?> "the definition of a variable (x = ...)"
where where
func pattern = func pattern =
case pattern of case pattern of
PVar _ -> (pattern:) <$> spacePrefix Pattern.term P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
_ -> do try (lookAhead (whitespace >> string "=")) _ -> do try (lookAhead (whitespace >> string "="))
return [pattern] return [pattern]
infics p1 = do infics p1 = do
o:p <- try (whitespace >> anyOp) o:p <- try (whitespace >> anyOp)
p2 <- (whitespace >> Pattern.term) p2 <- (whitespace >> Pattern.term)
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ] return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
else [ PVar (o:p), p1, p2 ] else [ P.Var (o:p), p1, p2 ]
makeFunction :: [Pattern] -> LParseExpr -> LParseExpr makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
makeFunction args body@(L s _) = makeFunction args body@(A ann _) =
foldr (\arg body' -> L s $ Lambda arg body') body args foldr (\arg body' -> A ann $ Lambda arg body') body args
definition :: IParser ParseDef definition :: IParser ParseDef
definition = withPos $ do definition = withPos $ do

27
compiler/Parse/Helpers.hs
View file

@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
import Text.Parsec.Indent import Text.Parsec.Indent
import qualified Text.Parsec.Token as T import qualified Text.Parsec.Token as T
import SourceSyntax.Helpers as Help import SourceSyntax.Annotation as Annotation
import SourceSyntax.Location as Location
import SourceSyntax.Expression
import SourceSyntax.PrettyPrint
import SourceSyntax.Declaration (Assoc) import SourceSyntax.Declaration (Assoc)
import SourceSyntax.Expression
import SourceSyntax.Helpers as Help
import SourceSyntax.PrettyPrint
import SourceSyntax.Variable as Variable
reserveds = [ "if", "then", "else" reserveds = [ "if", "then", "else"
, "case", "of" , "case", "of"
@ -181,10 +182,10 @@ parens = surround '(' ')' "paren"
brackets :: IParser a -> IParser a brackets :: IParser a -> IParser a
brackets = surround '{' '}' "bracket" brackets = surround '{' '}' "bracket"
addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a) addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
addLocation expr = do addLocation expr = do
(start, e, end) <- located expr (start, e, end) <- located expr
return (Location.at start end e) return (Annotation.at start end e)
located :: IParser a -> IParser (SourcePos, a, SourcePos) located :: IParser a -> IParser (SourcePos, a, SourcePos)
located p = do located p = do
@ -193,10 +194,10 @@ located p = do
end <- getPosition end <- getPosition
return (start, e, end) return (start, e, end)
accessible :: IParser LParseExpr -> IParser LParseExpr accessible :: IParser ParseExpr -> IParser ParseExpr
accessible expr = do accessible expr = do
start <- getPosition start <- getPosition
ce@(L _ e) <- expr ce@(A _ e) <- expr
let rest f = do let rest f = do
let dot = char '.' >> notFollowedBy (char '.') let dot = char '.' >> notFollowedBy (char '.')
access <- optionMaybe (try dot <?> "field access (e.g. List.map)") access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@ -205,10 +206,12 @@ accessible expr = do
Just _ -> accessible $ do Just _ -> accessible $ do
v <- var <?> "field access (e.g. List.map)" v <- var <?> "field access (e.g. List.map)"
end <- getPosition end <- getPosition
return (Location.at start end (f v)) return (Annotation.at start end (f v))
case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v)) case e of
| otherwise -> rest (Access ce) Var (Variable.Raw (c:cs))
_ -> rest (Access ce) | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
| otherwise -> rest (Access ce)
_ -> rest (Access ce)
spaces :: IParser String spaces :: IParser String

56
compiler/Parse/Pattern.hs
View file

@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.Char (isUpper) import Data.Char (isUpper)
import Data.List (intercalate) import qualified Data.List as List
import Text.Parsec hiding (newline,spaces,State) import Text.Parsec hiding (newline,spaces,State)
import Parse.Helpers import Parse.Helpers
import Parse.Literal import Parse.Literal
import SourceSyntax.Literal import SourceSyntax.Literal
import SourceSyntax.Pattern hiding (tuple, list) import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Pattern as Pattern
basic :: IParser Pattern basic :: IParser P.Pattern
basic = choice basic = choice
[ char '_' >> return PAnything [ char '_' >> return P.Anything
, do v <- var , do v <- var
return $ case v of return $ case v of
"True" -> PLiteral (Boolean True) "True" -> P.Literal (Boolean True)
"False" -> PLiteral (Boolean False) "False" -> P.Literal (Boolean False)
c:_ | isUpper c -> PData v [] c:_ | isUpper c -> P.Data v []
_ -> PVar v _ -> P.Var v
, PLiteral <$> literal , P.Literal <$> literal
] ]
asPattern :: Pattern -> IParser Pattern asPattern :: P.Pattern -> IParser P.Pattern
asPattern pattern = do asPattern pattern = do
var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar)) var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
return $ case var of return $ case var of
Just v -> PAlias v pattern Just v -> P.Alias v pattern
Nothing -> pattern Nothing -> pattern
record :: IParser Pattern record :: IParser P.Pattern
record = PRecord <$> brackets (commaSep1 lowVar) record = P.Record <$> brackets (commaSep1 lowVar)
tuple :: IParser Pattern tuple :: IParser P.Pattern
tuple = do ps <- parens (commaSep expr) tuple = do
return $ case ps of { [p] -> p; _ -> Pattern.tuple ps } ps <- parens (commaSep expr)
return $ case ps of
[p] -> p
_ -> P.tuple ps
list :: IParser Pattern list :: IParser P.Pattern
list = Pattern.list <$> braces (commaSep expr) list = P.list <$> braces (commaSep expr)
term :: IParser Pattern term :: IParser P.Pattern
term = term =
(choice [ record, tuple, list, basic ]) <?> "pattern" (choice [ record, tuple, list, basic ]) <?> "pattern"
patternConstructor :: IParser Pattern patternConstructor :: IParser P.Pattern
patternConstructor = do patternConstructor = do
v <- intercalate "." <$> dotSep1 capVar v <- List.intercalate "." <$> dotSep1 capVar
case v of case v of
"True" -> return $ PLiteral (Boolean True) "True" -> return $ P.Literal (Boolean True)
"False" -> return $ PLiteral (Boolean False) "False" -> return $ P.Literal (Boolean False)
_ -> PData v <$> spacePrefix term _ -> P.Data v <$> spacePrefix term
expr :: IParser Pattern expr :: IParser P.Pattern
expr = do expr = do
patterns <- consSep1 (patternConstructor <|> term) patterns <- consSep1 (patternConstructor <|> term)
asPattern (foldr1 Pattern.cons patterns) <?> "pattern" asPattern (foldr1 P.cons patterns) <?> "pattern"

74
compiler/SourceSyntax/Annotation.hs Normal file
View file

@ -0,0 +1,74 @@
{-# OPTIONS_GHC -W #-}
module SourceSyntax.Annotation where
import qualified Text.Parsec.Pos as Parsec
import qualified Text.PrettyPrint as P
import SourceSyntax.PrettyPrint
data Annotated annotation expr = A annotation expr
deriving (Show)
data Region
= Span Position Position P.Doc
| None P.Doc
deriving (Show)
data Position = Position
{ line :: Int
, column :: Int
} deriving (Show)
type Located expr = Annotated Region expr
none e = A (None (pretty e)) e
noneNoDocs e = A (None P.empty) e
at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
-> Annotated Region expr
at start end e =
A (Span (position start) (position end) (pretty e)) e
where
position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
merge (A s1 _) (A s2 _) e =
A (span (pretty e)) e
where
span = case (s1,s2) of
(Span start _ _, Span _ end _) -> Span start end
(Span start end _, _) -> Span start end
(_, Span start end _) -> Span start end
(_, _) -> None
mergeOldDocs (A s1 _) (A s2 _) e =
A span e
where
span = case (s1,s2) of
(Span start _ d1, Span _ end d2) ->
Span start end (P.vcat [d1, P.text "\n", d2])
(Span _ _ _, _) -> s1
(_, Span _ _ _) -> s2
(_, _) -> None P.empty
sameAs :: Annotated a expr -> expr' -> Annotated a expr'
sameAs (A annotation _) expr = A annotation expr
getRegionDocs region =
case region of
Span _ _ doc -> doc
None doc -> doc
instance Pretty Region where
pretty span =
case span of
None _ -> P.empty
Span start end _ ->
P.text $
case line start == line end of
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
True -> "on line " ++ show (line end) ++ ", column " ++
show (column start) ++ " to " ++ show (column end)
instance Pretty e => Pretty (Annotated a e) where
pretty (A _ e) = pretty e

4
compiler/SourceSyntax/Declaration.hs
View file

@ -20,11 +20,11 @@ data Assoc = L | N | R
data ParsePort data ParsePort
= PPAnnotation String T.Type = PPAnnotation String T.Type
| PPDef String Expr.LParseExpr | PPDef String Expr.ParseExpr
deriving (Show) deriving (Show)
data Port data Port
= Out String Expr.LExpr T.Type = Out String Expr.Expr T.Type
| In String T.Type | In String T.Type
deriving (Show) deriving (Show)

150
compiler/SourceSyntax/Expression.hs
View file

@ -11,49 +11,54 @@ module SourceSyntax.Expression where
import SourceSyntax.PrettyPrint import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P import Text.PrettyPrint as P
import qualified SourceSyntax.Helpers as Help import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Location as Location import qualified SourceSyntax.Annotation as Annotation
import qualified SourceSyntax.Pattern as Pattern import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Type as SrcType import qualified SourceSyntax.Type as SrcType
import qualified SourceSyntax.Literal as Literal import qualified SourceSyntax.Literal as Literal
import qualified SourceSyntax.Variable as Variable
---- GENERAL AST ---- ---- GENERAL AST ----
{-| This is a located expression, meaning it is tagged with info about where it
came from in the source code. Expr' is defined in terms of LExpr' so that the
location information does not need to be an extra field on every constructor.
-}
type LExpr' def = Location.Located (Expr' def)
{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has {-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
"type holes" that allow us to enrich the AST with additional information as we "type holes" that allow us to enrich the AST with additional information as we
move through the compilation process. The type holes let us show these move through the compilation process. The type holes are used to represent:
structural changes in the types. The only type hole right now is:
def: Parsing allows two kinds of definitions (type annotations or definitions), ann: Annotations for arbitrary expressions. Allows you to add information
but later checks will see that they are well formed and combine them. to the AST like position in source code or inferred types.
def: Definition style. The source syntax separates type annotations and
definitions, but after parsing we check that they are well formed and
collapse them.
var: Representation of variables. Starts as strings, but is later enriched
with information about what module a variable came from.
-} -}
data Expr' def type GeneralExpr annotation definition variable =
Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
data GeneralExpr' ann def var
= Literal Literal.Literal = Literal Literal.Literal
| Var String | Var var
| Range (LExpr' def) (LExpr' def) | Range (GeneralExpr ann def var) (GeneralExpr ann def var)
| ExplicitList [LExpr' def] | ExplicitList [GeneralExpr ann def var]
| Binop String (LExpr' def) (LExpr' def) | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
| Lambda Pattern.Pattern (LExpr' def) | Lambda Pattern.Pattern (GeneralExpr ann def var)
| App (LExpr' def) (LExpr' def) | App (GeneralExpr ann def var) (GeneralExpr ann def var)
| MultiIf [(LExpr' def,LExpr' def)] | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
| Let [def] (LExpr' def) | Let [def] (GeneralExpr ann def var)
| Case (LExpr' def) [(Pattern.Pattern, LExpr' def)] | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
| Data String [LExpr' def] | Data String [GeneralExpr ann def var]
| Access (LExpr' def) String | Access (GeneralExpr ann def var) String
| Remove (LExpr' def) String | Remove (GeneralExpr ann def var) String
| Insert (LExpr' def) String (LExpr' def) | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
| Modify (LExpr' def) [(String, LExpr' def)] | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
| Record [(String, LExpr' def)] | Record [(String, GeneralExpr ann def var)]
| Markdown String String [LExpr' def] | Markdown String String [GeneralExpr ann def var]
-- for type checking and code gen only -- for type checking and code gen only
| PortIn String SrcType.Type | PortIn String SrcType.Type
| PortOut String SrcType.Type (LExpr' def) | PortOut String SrcType.Type (GeneralExpr ann def var)
deriving (Show)
---- SPECIALIZED ASTs ---- ---- SPECIALIZED ASTs ----
@ -62,81 +67,100 @@ data Expr' def
annotations and definitions, which is how they appear in source code and how annotations and definitions, which is how they appear in source code and how
they are parsed. they are parsed.
-} -}
type ParseExpr = Expr' ParseDef type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
type LParseExpr = LExpr' ParseDef type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
data ParseDef data ParseDef
= Def Pattern.Pattern LParseExpr = Def Pattern.Pattern ParseExpr
| TypeAnnotation String SrcType.Type | TypeAnnotation String SrcType.Type
deriving (Show) deriving (Show)
{-| "Normal" expressions. When the compiler checks that type annotations and {-| "Normal" expressions. When the compiler checks that type annotations and
ports are all paired with definitions in the appropriate order, it collapses ports are all paired with definitions in the appropriate order, it collapses
them into a Def that is easier to work with in later phases of compilation. them into a Def that is easier to work with in later phases of compilation.
-} -}
type LExpr = LExpr' Def type Expr = GeneralExpr Annotation.Region Def Variable.Raw
type Expr = Expr' Def type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type) data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
deriving (Show) deriving (Show)
---- UTILITIES ---- ---- UTILITIES ----
tuple :: [LExpr' def] -> Expr' def rawVar :: String -> GeneralExpr' ann def Variable.Raw
rawVar x = Var (Variable.Raw x)
tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
tuple es = Data ("_Tuple" ++ show (length es)) es tuple es = Data ("_Tuple" ++ show (length es)) es
delist :: LExpr' def -> [LExpr' def] delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
delist (Location.L _ (Data "::" [h,t])) = h : delist t delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
delist _ = [] delist _ = []
saveEnvName :: String saveEnvName :: String
saveEnvName = "_save_the_environment!!!" saveEnvName = "_save_the_environment!!!"
dummyLet :: Pretty def => [def] -> LExpr' def dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
dummyLet defs = dummyLet defs =
Location.none $ Let defs (Location.none $ Var saveEnvName) Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
instance Pretty def => Show (Expr' def) where instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
show = render . pretty
instance Pretty def => Pretty (Expr' def) where
pretty expr = pretty expr =
case expr of case expr of
Literal lit -> pretty lit Literal lit -> pretty lit
Var x -> variable x
Var x -> pretty x
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2) Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
ExplicitList es -> P.brackets (commaCat (map pretty es)) ExplicitList es -> P.brackets (commaCat (map pretty es))
Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
P.text "-" <> prettyParens e P.text "-" <> prettyParens e
Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ] Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
where op' = if Help.isOp op then op else "`" ++ op ++ "`" where
op' = if Help.isOp op then op else "`" ++ op ++ "`"
Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
where where
(ps,body) = collectLambdas (Location.none $ Lambda p e) (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
args = P.sep (map Pattern.prettyParens ps) args = P.sep (map Pattern.prettyParens ps)
App _ _ -> P.hang func 2 (P.sep args) App _ _ -> P.hang func 2 (P.sep args)
where func:args = map prettyParens (collectApps (Location.none expr)) where
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches) func:args = map prettyParens (collectApps (Annotation.A undefined expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
where where
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e) iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
Let defs e -> Let defs e ->
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs)) P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
, P.text "in" <+> pretty e ] , P.text "in" <+> pretty e ]
Case e pats -> Case e pats ->
P.hang pexpr 2 (P.vcat (map pretty' pats)) P.hang pexpr 2 (P.vcat (map pretty' pats))
where where
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ] pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
Data "[]" [] -> P.text "[]" Data "[]" [] -> P.text "[]"
Data name es Data name es
| Help.isTuple name -> P.parens (commaCat (map pretty es)) | Help.isTuple name -> P.parens (commaCat (map pretty es))
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es)) | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
Access e x -> prettyParens e <> P.text "." <> variable x Access e x -> prettyParens e <> P.text "." <> variable x
Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x) Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
Insert (Location.L _ (Remove e y)) x v ->
P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v) Insert (Annotation.A _ (Remove e y)) x v ->
P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
, variable x, P.equals, pretty v ]
Insert e x v -> Insert e x v ->
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v) P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
@ -175,21 +199,23 @@ instance Pretty Def where
Nothing -> P.empty Nothing -> P.empty
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
collectApps :: LExpr' def -> [LExpr' def] collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
collectApps lexpr@(Location.L _ expr) = collectApps annExpr@(Annotation.A _ expr) =
case expr of case expr of
App a b -> collectApps a ++ [b] App a b -> collectApps a ++ [b]
_ -> [lexpr] _ -> [annExpr]
collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def) collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
collectLambdas lexpr@(Location.L _ expr) = collectLambdas lexpr@(Annotation.A _ expr) =
case expr of case expr of
Lambda pattern body -> (pattern : ps, body') Lambda pattern body ->
where (ps, body') = collectLambdas body let (ps, body') = collectLambdas body
in (pattern : ps, body')
_ -> ([], lexpr) _ -> ([], lexpr)
prettyParens :: (Pretty def) => LExpr' def -> Doc prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
prettyParens (Location.L _ expr) = parensIf needed (pretty expr) prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
where where
needed = needed =
case expr of case expr of

58
compiler/SourceSyntax/Location.hs
View file

@ -1,58 +0,0 @@
module SourceSyntax.Location where
import Text.PrettyPrint
import SourceSyntax.PrettyPrint
import qualified Text.Parsec.Pos as Parsec
data SrcPos = Pos { line :: Int, column :: Int }
deriving (Eq, Ord)
data SrcSpan = Span SrcPos SrcPos String | NoSpan String
deriving (Eq, Ord)
data Located e = L SrcSpan e
deriving (Eq, Ord)
none e = L (NoSpan (render $ pretty e)) e
noneNoDocs = L (NoSpan "")
at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
(Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
(render $ pretty e)) e
merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
where span = case (s1,s2) of
(Span start _ _, Span _ end _) -> Span start end
(Span start end _, _) -> Span start end
(_, Span start end _) -> Span start end
(_, _) -> NoSpan
mergeOldDocs (L s1 _) (L s2 _) e = L span e
where span = case (s1,s2) of
(Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
(Span _ _ _, _) -> s1
(_, Span _ _ _) -> s2
(_, _) -> NoSpan ""
sameAs (L s _) = L s
instance Show SrcPos where
show (Pos r c) = show r ++ "," ++ show c
instance Show SrcSpan where
show span =
case span of
NoSpan _ -> ""
Span start end _ ->
case line start == line end of
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
True -> "on line " ++ show (line end) ++ ", column " ++
show (column start) ++ " to " ++ show (column end)
instance Show e => Show (Located e) where
show (L _ e) = show e
instance Pretty a => Pretty (Located a) where
pretty (L _ e) = pretty e

4
compiler/SourceSyntax/Module.hs
View file

@ -7,7 +7,7 @@ import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Text.PrettyPrint as P import Text.PrettyPrint as P
import SourceSyntax.Expression (LExpr) import SourceSyntax.Expression (Expr)
import SourceSyntax.Declaration import SourceSyntax.Declaration
import SourceSyntax.PrettyPrint import SourceSyntax.PrettyPrint
import SourceSyntax.Type import SourceSyntax.Type
@ -72,7 +72,7 @@ data MetadataModule =
, path :: FilePath , path :: FilePath
, exports :: [String] , exports :: [String]
, imports :: [(String, ImportMethod)] , imports :: [(String, ImportMethod)]
, program :: LExpr , program :: Expr
, types :: Map.Map String Type , types :: Map.Map String Type
, fixities :: [(Assoc, Int, String)] , fixities :: [(Assoc, Int, String)]
, aliases :: [Alias] , aliases :: [Alias]

56
compiler/SourceSyntax/Pattern.hs
View file

@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
import qualified Data.Set as Set import qualified Data.Set as Set
import SourceSyntax.Literal as Literal import SourceSyntax.Literal as Literal
data Pattern = PData String [Pattern] data Pattern
| PRecord [String] = Data String [Pattern]
| PAlias String Pattern | Record [String]
| PVar String | Alias String Pattern
| PAnything | Var String
| PLiteral Literal.Literal | Anything
deriving (Eq, Ord, Show) | Literal Literal.Literal
deriving (Eq, Ord, Show)
cons :: Pattern -> Pattern -> Pattern cons :: Pattern -> Pattern -> Pattern
cons h t = PData "::" [h,t] cons h t = Data "::" [h,t]
nil :: Pattern nil :: Pattern
nil = PData "[]" [] nil = Data "[]" []
list :: [Pattern] -> Pattern list :: [Pattern] -> Pattern
list = foldr cons nil list = foldr cons nil
tuple :: [Pattern] -> Pattern tuple :: [Pattern] -> Pattern
tuple es = PData ("_Tuple" ++ show (length es)) es tuple es = Data ("_Tuple" ++ show (length es)) es
boundVarList :: Pattern -> [String]
boundVarList = Set.toList . boundVars
boundVars :: Pattern -> Set.Set String boundVars :: Pattern -> Set.Set String
boundVars pattern = boundVars pattern =
case pattern of case pattern of
PVar x -> Set.singleton x Var x -> Set.singleton x
PAlias x p -> Set.insert x (boundVars p) Alias x p -> Set.insert x (boundVars p)
PData _ ps -> Set.unions (map boundVars ps) Data _ ps -> Set.unions (map boundVars ps)
PRecord fields -> Set.fromList fields Record fields -> Set.fromList fields
PAnything -> Set.empty Anything -> Set.empty
PLiteral _ -> Set.empty Literal _ -> Set.empty
instance Pretty Pattern where instance Pretty Pattern where
pretty pattern = pretty pattern =
case pattern of case pattern of
PVar x -> variable x Var x -> variable x
PLiteral lit -> pretty lit Literal lit -> pretty lit
PRecord fs -> PP.braces (commaCat $ map variable fs) Record fs -> PP.braces (commaCat $ map variable fs)
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
PAnything -> PP.text "_" Anything -> PP.text "_"
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
where isCons = case hd of where isCons = case hd of
PData "::" _ -> True Data "::" _ -> True
_ -> False _ -> False
PData name ps -> Data name ps ->
if Help.isTuple name then if Help.isTuple name then
PP.parens . commaCat $ map pretty ps PP.parens . commaCat $ map pretty ps
else hsep (PP.text name : map prettyParens ps) else hsep (PP.text name : map prettyParens ps)
@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
where where
needsThem = needsThem =
case pattern of case pattern of
PData name (_:_) | not (Help.isTuple name) -> True Data name (_:_) | not (Help.isTuple name) -> True
PAlias _ _ -> True Alias _ _ -> True
_ -> False _ -> False

5
compiler/SourceSyntax/PrettyPrint.hs
View file

@ -10,11 +10,16 @@ class Pretty a where
instance Pretty () where instance Pretty () where
pretty () = empty pretty () = empty
renderPretty :: (Pretty a) => a -> String
renderPretty e = render (pretty e)
commaCat docs = cat (punctuate comma docs) commaCat docs = cat (punctuate comma docs)
commaSep docs = sep (punctuate comma docs) commaSep docs = sep (punctuate comma docs)
parensIf :: Bool -> Doc -> Doc
parensIf bool doc = if bool then parens doc else doc parensIf bool doc = if bool then parens doc else doc
variable :: String -> Doc
variable x = variable x =
if Help.isOp x then parens (text x) if Help.isOp x then parens (text x)
else text (reprime x) else text (reprime x)

9
compiler/SourceSyntax/Type.hs
View file

@ -1,18 +1,18 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module SourceSyntax.Type where module SourceSyntax.Type where
import Control.Applicative ((<$>), (<*>))
import Data.Binary import Data.Binary
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified SourceSyntax.Helpers as Help
import Control.Applicative ((<$>), (<*>))
import SourceSyntax.PrettyPrint import SourceSyntax.PrettyPrint
import qualified SourceSyntax.Helpers as Help
import Text.PrettyPrint as P import Text.PrettyPrint as P
data Type = Lambda Type Type data Type = Lambda Type Type
| Var String | Var String
| Data String [Type] | Data String [Type]
| Record [(String,Type)] (Maybe String) | Record [(String,Type)] (Maybe String)
deriving (Eq) deriving (Eq,Show)
fieldMap :: [(String,a)] -> Map.Map String [a] fieldMap :: [(String,a)] -> Map.Map String [a]
fieldMap fields = fieldMap fields =
@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
tupleOf :: [Type] -> Type tupleOf :: [Type] -> Type
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
instance Show Type where
show = render . pretty
instance Pretty Type where instance Pretty Type where
pretty tipe = pretty tipe =
case tipe of case tipe of

11
compiler/SourceSyntax/Variable.hs Normal file
View file

@ -0,0 +1,11 @@
module SourceSyntax.Variable where
import qualified Text.PrettyPrint as P
import SourceSyntax.PrettyPrint
newtype Raw = Raw String
deriving (Eq,Ord,Show)
instance Pretty Raw where
pretty (Raw var) = variable var

44
compiler/Transform/Canonicalize.hs
View file

@ -1,19 +1,20 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -Wall #-}
module Transform.Canonicalize (interface, metadataModule) where module Transform.Canonicalize (interface, metadataModule) where
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Applicative (Applicative,(<$>),(<*>)) import Control.Applicative (Applicative,(<$>),(<*>))
import Control.Monad.Identity import Control.Monad.Identity
import qualified Data.Traversable as T import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.Traversable as T
import qualified Data.Either as Either import SourceSyntax.Annotation as A
import SourceSyntax.Module
import SourceSyntax.Expression import SourceSyntax.Expression
import SourceSyntax.Location as Loc import SourceSyntax.Module
import qualified SourceSyntax.Pattern as P import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as Type import qualified SourceSyntax.Type as Type
import qualified SourceSyntax.Variable as Var
import Text.PrettyPrint as P import Text.PrettyPrint as P
interface :: String -> ModuleInterface -> ModuleInterface interface :: String -> ModuleInterface -> ModuleInterface
@ -96,8 +97,7 @@ type Env = Map.Map String String
extend :: Env -> P.Pattern -> Env extend :: Env -> P.Pattern -> Env
extend env pattern = Map.union (Map.fromList (zip xs xs)) env extend env pattern = Map.union (Map.fromList (zip xs xs)) env
where xs = Set.toList (P.boundVars pattern) where xs = P.boundVarList pattern
replace :: String -> Env -> String -> Either String String replace :: String -> Env -> String -> Either String String
replace variable env v = replace variable env v =
@ -110,14 +110,15 @@ replace variable env v =
msg = if null matches then "" else msg = if null matches then "" else
"\nClose matches include: " ++ List.intercalate ", " matches "\nClose matches include: " ++ List.intercalate ", " matches
rename :: Env -> LExpr -> Either [Doc] LExpr -- TODO: Var.Raw -> Var.Canonical
rename env (L s expr) = rename :: Env -> Expr -> Either [Doc] Expr
rename env (A ann expr) =
let rnm = rename env let rnm = rename env
throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ] throw err = Left [ P.text $ "Error " ++ show ann ++ "\n" ++ err ]
format = Either.either throw return format = Either.either throw return
renameType' env = renameType (format . replace "variable" env) renameType' environ = renameType (format . replace "variable" environ)
in in
L s <$> A ann <$>
case expr of case expr of
Literal _ -> return expr Literal _ -> return expr
@ -155,7 +156,8 @@ rename env (L s expr) =
<*> rename env' body <*> rename env' body
<*> T.traverse (renameType' env') mtipe <*> T.traverse (renameType' env') mtipe
Var x -> Var <$> format (replace "variable" env x) -- TODO: Raw -> Canonical
Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
Data name es -> Data name <$> mapM rnm es Data name es -> Data name <$> mapM rnm es
@ -176,10 +178,10 @@ rename env (L s expr) =
renamePattern :: Env -> P.Pattern -> Either String P.Pattern renamePattern :: Env -> P.Pattern -> Either String P.Pattern
renamePattern env pattern = renamePattern env pattern =
case pattern of case pattern of
P.PVar _ -> return pattern P.Var _ -> return pattern
P.PLiteral _ -> return pattern P.Literal _ -> return pattern
P.PRecord _ -> return pattern P.Record _ -> return pattern
P.PAnything -> return pattern P.Anything -> return pattern
P.PAlias x p -> P.PAlias x <$> renamePattern env p P.Alias x p -> P.Alias x <$> renamePattern env p
P.PData name ps -> P.PData <$> replace "pattern" env name P.Data name ps -> P.Data <$> replace "pattern" env name
<*> mapM (renamePattern env) ps <*> mapM (renamePattern env) ps

2
compiler/Transform/Declaration.hs
View file

@ -42,7 +42,7 @@ combineAnnotations = go
TypeAnnotation name tipe -> TypeAnnotation name tipe ->
case defRest of case defRest of
D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' -> D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
do expr' <- exprCombineAnnotations expr do expr' <- exprCombineAnnotations expr
let def' = E.Definition pat expr' (Just tipe) let def' = E.Definition pat expr' (Just tipe)
(:) (D.Definition def') <$> go rest (:) (D.Definition def') <$> go rest

2
compiler/Transform/Definition.hs
View file

@ -16,7 +16,7 @@ combineAnnotations = go
go defs = go defs =
case defs of case defs of
TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' -> TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
do expr' <- exprCombineAnnotations expr do expr' <- exprCombineAnnotations expr
let def = Definition pat expr' (Just tipe) let def = Definition pat expr' (Just tipe)
(:) def <$> go rest (:) def <$> go rest

28
compiler/Transform/Expression.hs
View file

@ -2,17 +2,19 @@
module Transform.Expression (crawlLet, checkPorts) where module Transform.Expression (crawlLet, checkPorts) where
import Control.Applicative ((<$>),(<*>)) import Control.Applicative ((<$>),(<*>))
import SourceSyntax.Annotation ( Annotated(A) )
import SourceSyntax.Expression import SourceSyntax.Expression
import SourceSyntax.Location import SourceSyntax.Type (Type)
import qualified SourceSyntax.Type as ST
crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def') crawlLet :: ([def] -> Either a [def'])
-> GeneralExpr ann def var
-> Either a (GeneralExpr ann def' var)
crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ()) crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
checkPorts :: (String -> ST.Type -> Either a ()) checkPorts :: (String -> Type -> Either a ())
-> (String -> ST.Type -> Either a ()) -> (String -> Type -> Either a ())
-> LExpr -> Expr
-> Either a LExpr -> Either a Expr
checkPorts inCheck outCheck expr = checkPorts inCheck outCheck expr =
crawl inCheck outCheck (mapM checkDef) expr crawl inCheck outCheck (mapM checkDef) expr
where where
@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
do _ <- checkPorts inCheck outCheck body do _ <- checkPorts inCheck outCheck body
return def return def
crawl :: (String -> ST.Type -> Either a ()) crawl :: (String -> Type -> Either a ())
-> (String -> ST.Type -> Either a ()) -> (String -> Type -> Either a ())
-> ([def] -> Either a [def']) -> ([def] -> Either a [def'])
-> LExpr' def -> GeneralExpr ann def var
-> Either a (LExpr' def') -> Either a (GeneralExpr ann def' var)
crawl portInCheck portOutCheck defsTransform = go crawl portInCheck portOutCheck defsTransform = go
where where
go (L srcSpan expr) = go (A srcSpan expr) =
L srcSpan <$> A srcSpan <$>
case expr of case expr of
Var x -> return (Var x) Var x -> return (Var x)
Lambda p e -> Lambda p <$> go e Lambda p e -> Lambda p <$> go e

37
compiler/Transform/SafeNames.hs
View file

@ -1,43 +1,44 @@
{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wall #-}
module Transform.SafeNames (metadataModule) where module Transform.SafeNames (metadataModule) where
import Control.Arrow (first, (***)) import Control.Arrow (first, (***))
import Data.List (intercalate) import qualified Data.List as List
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Parse.Helpers as PHelp import qualified Parse.Helpers as PHelp
import SourceSyntax.Annotation
import SourceSyntax.Expression import SourceSyntax.Expression
import qualified SourceSyntax.Helpers as SHelp import qualified SourceSyntax.Helpers as SHelp
import SourceSyntax.Location
import SourceSyntax.Module import SourceSyntax.Module
import SourceSyntax.Pattern import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as Variable
var :: String -> String var :: String -> String
var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
where where
deprime = map (\c -> if c == '\'' then '$' else c) deprime = map (\c -> if c == '\'' then '$' else c)
dereserve x = case Set.member x PHelp.jsReserveds of dereserve x = case Set.member x PHelp.jsReserveds of
False -> x False -> x
True -> "$" ++ x True -> "$" ++ x
pattern :: Pattern -> Pattern pattern :: P.Pattern -> P.Pattern
pattern pat = pattern pat =
case pat of case pat of
PVar x -> PVar (var x) P.Var x -> P.Var (var x)
PLiteral _ -> pat P.Literal _ -> pat
PRecord fs -> PRecord (map var fs) P.Record fs -> P.Record (map var fs)
PAnything -> pat P.Anything -> pat
PAlias x p -> PAlias (var x) (pattern p) P.Alias x p -> P.Alias (var x) (pattern p)
PData name ps -> PData name (map pattern ps) P.Data name ps -> P.Data name (map pattern ps)
expression :: LExpr -> LExpr -- TODO: should be "normal expression" -> "expression for JS generation"
expression (L loc expr) = expression :: Expr -> Expr
expression (A ann expr) =
let f = expression in let f = expression in
L loc $ A ann $
case expr of case expr of
Literal _ -> expr Literal _ -> expr
Var x -> Var (var x) Var (Variable.Raw x) -> rawVar (var x)
Range e1 e2 -> Range (f e1) (f e2) Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es) ExplicitList es -> ExplicitList (map f es)
Binop op e1 e2 -> Binop op (f e1) (f e2) Binop op e1 e2 -> Binop op (f e1) (f e2)

37
compiler/Transform/SortDefinitions.hs
View file

@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where
import Control.Monad.State import Control.Monad.State
import Control.Applicative ((<$>),(<*>)) import Control.Applicative ((<$>),(<*>))
import qualified Data.Map as Map
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Pattern as P
import qualified Data.Graph as Graph import qualified Data.Graph as Graph
import qualified Data.Set as Set import qualified Data.Map as Map
import qualified Data.Maybe as Maybe import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as V
ctors :: P.Pattern -> [String] ctors :: P.Pattern -> [String]
ctors pattern = ctors pattern =
case pattern of case pattern of
P.PVar _ -> [] P.Var _ -> []
P.PAlias _ p -> ctors p P.Alias _ p -> ctors p
P.PData ctor ps -> ctor : concatMap ctors ps P.Data ctor ps -> ctor : concatMap ctors ps
P.PRecord _ -> [] P.Record _ -> []
P.PAnything -> [] P.Anything -> []
P.PLiteral _ -> [] P.Literal _ -> []
free :: String -> State (Set.Set String) () free :: String -> State (Set.Set String) ()
free x = modify (Set.insert x) free x = modify (Set.insert x)
@ -27,15 +28,15 @@ free x = modify (Set.insert x)
bound :: Set.Set String -> State (Set.Set String) () bound :: Set.Set String -> State (Set.Set String) ()
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars) bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
sortDefs :: LExpr -> LExpr sortDefs :: Expr -> Expr
sortDefs expr = evalState (reorder expr) Set.empty sortDefs expr = evalState (reorder expr) Set.empty
reorder :: LExpr -> State (Set.Set String) LExpr reorder :: Expr -> State (Set.Set String) Expr
reorder (L s expr) = reorder (A ann expr) =
L s <$> A ann <$>
case expr of case expr of
-- Be careful adding and restricting freeVars -- Be careful adding and restricting freeVars
Var x -> free x >> return expr Var (V.Raw x) -> free x >> return expr
Lambda p e -> Lambda p e ->
uncurry Lambda <$> bindingReorder (p,e) uncurry Lambda <$> bindingReorder (p,e)
@ -103,11 +104,11 @@ reorder (L s expr) =
bound (P.boundVars pattern) bound (P.boundVars pattern)
mapM free (ctors pattern) mapM free (ctors pattern)
let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
return let' return let'
bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr) bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
bindingReorder (pattern,expr) = bindingReorder (pattern,expr) =
do expr' <- reorder expr do expr' <- reorder expr
bound (P.boundVars pattern) bound (P.boundVars pattern)

16
compiler/Transform/Substitute.hs
View file

@ -2,14 +2,16 @@
module Transform.Substitute (subst) where module Transform.Substitute (subst) where
import Control.Arrow (second, (***)) import Control.Arrow (second, (***))
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Pattern as Pattern
import qualified Data.Set as Set import qualified Data.Set as Set
subst :: String -> Expr -> Expr -> Expr import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Variable as V
subst :: String -> Expr' -> Expr' -> Expr'
subst old new expr = subst old new expr =
let f (L s e) = L s (subst old new e) in let f (A a e) = A a (subst old new e) in
case expr of case expr of
Range e1 e2 -> Range (f e1) (f e2) Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es) ExplicitList es -> ExplicitList (map f es)
@ -28,7 +30,7 @@ subst old new expr =
anyShadow = anyShadow =
any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ] any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
Var x -> if x == old then new else expr Var (V.Raw x) -> if x == old then new else expr
Case e cases -> Case (f e) $ map (second f) cases Case e cases -> Case (f e) $ map (second f) cases
Data name es -> Data name (map f es) Data name es -> Data name (map f es)
Access e x -> Access (f e) x Access e x -> Access (f e) x
@ -39,4 +41,4 @@ subst old new expr =
Literal _ -> expr Literal _ -> expr
Markdown uid md es -> Markdown uid md (map f es) Markdown uid md es -> Markdown uid md (map f es)
PortIn name st -> PortIn name st PortIn name st -> PortIn name st
PortOut name st signal -> PortOut name st (f signal) PortOut name st signal -> PortOut name st (f signal)

46
compiler/Type/Constrain/Declaration.hs
View file

@ -1,62 +1,62 @@
{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wall #-}
module Type.Constrain.Declaration where module Type.Constrain.Declaration where
import SourceSyntax.Declaration import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Declaration as D
import qualified SourceSyntax.Expression as E import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Location as L
import qualified SourceSyntax.Pattern as P import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T import qualified SourceSyntax.Type as T
toExpr :: [Declaration] -> [E.Def] toExpr :: [D.Declaration] -> [E.Def]
toExpr = concatMap toDefs toExpr = concatMap toDefs
toDefs :: Declaration -> [E.Def] toDefs :: D.Declaration -> [E.Def]
toDefs decl = toDefs decl =
case decl of case decl of
Definition def -> [def] D.Definition def -> [def]
Datatype name tvars constructors -> concatMap toDefs' constructors D.Datatype name tvars constructors -> concatMap toDefs' constructors
where where
toDefs' (ctor, tipes) = toDefs' (ctor, tipes) =
let vars = take (length tipes) arguments let vars = take (length tipes) arguments
tbody = T.Data name $ map T.Var tvars tbody = T.Data name $ map T.Var tvars
body = L.none . E.Data ctor $ map (L.none . E.Var) vars body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ] in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
TypeAlias name _ tipe@(T.Record fields ext) -> D.TypeAlias name _ tipe@(T.Record fields ext) ->
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ] [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
where where
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
var = L.none . E.Var var = A.none . E.rawVar
vars = take (length args) arguments vars = take (length args) arguments
efields = zip (map fst fields) (map var vars) efields = zip (map fst fields) (map var vars)
record = case ext of record = case ext of
Nothing -> L.none $ E.Record efields Nothing -> A.none $ E.Record efields
Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
-- Type aliases must be added to an extended equality dictionary, -- Type aliases must be added to an extended equality dictionary,
-- but they do not require any basic constraints. -- but they do not require any basic constraints.
TypeAlias _ _ _ -> [] D.TypeAlias _ _ _ -> []
Port port -> D.Port port ->
case port of case port of
Out name expr@(L.L s _) tipe -> D.Out name expr@(A.A s _) tipe ->
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ] [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
In name tipe -> D.In name tipe ->
[ definition name (L.none $ E.PortIn name tipe) tipe ] [ definition name (A.none $ E.PortIn name tipe) tipe ]
-- no constraints are needed for fixity declarations -- no constraints are needed for fixity declarations
Fixity _ _ _ -> [] D.Fixity _ _ _ -> []
arguments :: [String] arguments :: [String]
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..] arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
buildFunction :: E.LExpr -> [String] -> E.LExpr buildFunction :: E.Expr -> [String] -> E.Expr
buildFunction body@(L.L s _) vars = buildFunction body@(A.A s _) vars =
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars) foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
definition :: String -> E.LExpr -> T.Type -> E.Def definition :: String -> E.Expr -> T.Type -> E.Def
definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe) definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

67
compiler/Type/Constrain/Expression.hs
View file

@ -1,38 +1,39 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Type.Constrain.Expression where module Type.Constrain.Expression where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import qualified Control.Monad as Monad import qualified Control.Monad as Monad
import Control.Monad.Error import Control.Monad.Error
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import SourceSyntax.Location as Loc import SourceSyntax.Annotation as Ann
import SourceSyntax.Pattern (Pattern(PVar), boundVars)
import SourceSyntax.Expression import SourceSyntax.Expression
import qualified SourceSyntax.Type as SrcT import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as ST
import qualified SourceSyntax.Variable as V
import Type.Type hiding (Descriptor(..)) import Type.Type hiding (Descriptor(..))
import Type.Fragment import Type.Fragment
import qualified Type.Environment as Env import qualified Type.Environment as Env
import qualified Type.Constrain.Literal as Literal import qualified Type.Constrain.Literal as Literal
import qualified Type.Constrain.Pattern as Pattern import qualified Type.Constrain.Pattern as Pattern
constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (L span expr) tipe = constrain env (A region expr) tipe =
let list t = Env.get env Env.types "_List" <| t let list t = Env.get env Env.types "_List" <| t
and = L span . CAnd and = A region . CAnd
true = L span CTrue true = A region CTrue
t1 === t2 = L span (CEqual t1 t2) t1 === t2 = A region (CEqual t1 t2)
x <? t = L span (CInstance x t) x <? t = A region (CInstance x t)
clet schemes c = L span (CLet schemes c) clet schemes c = A region (CLet schemes c)
in in
case expr of case expr of
Literal lit -> liftIO $ Literal.constrain env span lit tipe Literal lit -> liftIO $ Literal.constrain env region lit tipe
Var name | name == saveEnvName -> return (L span CSaveEnv) Var (V.Raw name)
| otherwise -> return (name <? tipe) | name == saveEnvName -> return (A region CSaveEnv)
| otherwise -> return (name <? tipe)
Range lo hi -> Range lo hi ->
exists $ \x -> do exists $ \x -> do
@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
Lambda p e -> Lambda p e ->
exists $ \t1 -> exists $ \t1 ->
exists $ \t2 -> do exists $ \t2 -> do
fragment <- try span $ Pattern.constrain env p t1 fragment <- try region $ Pattern.constrain env p t1
c2 <- constrain env e t2 c2 <- constrain env e t2
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)] let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
(typeConstraint fragment /\ c2 )) (typeConstraint fragment /\ c2 ))
@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
exists $ \t -> do exists $ \t -> do
ce <- constrain env exp t ce <- constrain env exp t
let branch (p,e) = do let branch (p,e) = do
fragment <- try span $ Pattern.constrain env p t fragment <- try region $ Pattern.constrain env p t
clet [toScheme fragment] <$> constrain env e tipe clet [toScheme fragment] <$> constrain env e tipe
and . (:) ce <$> mapM branch branches and . (:) ce <$> mapM branch branches
@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
Modify e fields -> Modify e fields ->
exists $ \t -> do exists $ \t -> do
oldVars <- forM fields $ \_ -> liftIO (var Flexible) oldVars <- forM fields $ \_ -> liftIO (var Flexible)
let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars)) let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
cOld <- ex oldVars <$> constrain env e (record oldFields t) cOld <- ex oldVars <$> constrain env e (record oldFields t)
newVars <- forM fields $ \_ -> liftIO (var Flexible) newVars <- forM fields $ \_ -> liftIO (var Flexible)
let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars)) let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
let cNew = tipe === record newFields t let cNew = tipe === record newFields t
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars) cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
Record fields -> Record fields ->
do vars <- forM fields $ \_ -> liftIO (var Flexible) do vars <- forM fields $ \_ -> liftIO (var Flexible)
cs <- zipWithM (constrain env) (map snd fields) (map VarN vars) cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars)) let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
recordType = record fields' (TermN EmptyRecord1) recordType = record fields' (TermN EmptyRecord1)
return . ex vars . and $ tipe === recordType : cs return . ex vars . and $ tipe === recordType : cs
@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here. do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
-- Currently, qs is always []. -- Currently, qs is always [].
case (pattern, maybeTipe) of case (pattern, maybeTipe) of
(PVar name, Just tipe) -> do (P.Var name, Just tipe) -> do
flexiVars <- forM qs (\_ -> liftIO $ var Flexible) flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts } env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
(vars, typ) <- Env.instantiateType env tipe Map.empty (vars, typ) <- Env.instantiateType env tipe Map.empty
let scheme = Scheme { rigidQuantifiers = [], let scheme = Scheme { rigidQuantifiers = [],
flexibleQuantifiers = flexiVars ++ vars, flexibleQuantifiers = flexiVars ++ vars,
constraint = Loc.noneNoDocs CTrue, constraint = Ann.noneNoDocs CTrue,
header = Map.singleton name typ } header = Map.singleton name typ }
c <- constrain env' expr typ c <- constrain env' expr typ
return ( scheme : schemes return ( scheme : schemes
@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
, c2 , c2
, fl rigidVars c /\ c1 ) , fl rigidVars c /\ c1 )
(PVar name, Nothing) -> do (P.Var name, Nothing) -> do
v <- liftIO $ var Flexible v <- liftIO $ var Flexible
let tipe = VarN v let tipe = VarN v
inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
_ -> error (show pattern) _ -> error (show pattern)
expandPattern :: Def -> [Def] expandPattern :: Def -> [Def]
expandPattern def@(Definition pattern lexpr@(L s _) maybeType) = expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
case pattern of case pattern of
PVar _ -> [def] P.Var _ -> [def]
_ -> Definition (PVar x) lexpr maybeType : map toDef vars _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
where where
vars = Set.toList $ boundVars pattern vars = P.boundVarList pattern
x = "$" ++ concat vars x = "$" ++ concat vars
mkVar = L s . Var mkVar = A r . rawVar
toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
try span computation = do try region computation = do
result <- liftIO $ runErrorT computation result <- liftIO $ runErrorT computation
case result of case result of
Left err -> throwError [err span] Left err -> throwError [err region]
Right value -> return value Right value -> return value

9
compiler/Type/Constrain/Literal.hs
View file

@ -1,14 +1,15 @@
{-# OPTIONS_GHC -W #-}
module Type.Constrain.Literal where module Type.Constrain.Literal where
import SourceSyntax.Annotation
import SourceSyntax.Literal import SourceSyntax.Literal
import SourceSyntax.Location
import Type.Type import Type.Type
import Type.Environment as Env import Type.Environment as Env
constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
constrain env span literal tipe = constrain env region literal tipe =
do tipe' <- litType do tipe' <- litType
return . L span $ CEqual tipe tipe' return . A region $ CEqual tipe tipe'
where where
prim name = return (Env.get env Env.types name) prim name = return (Env.get env Env.types name)

35
compiler/Type/Constrain/Pattern.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Type.Constrain.Pattern where module Type.Constrain.Pattern where
@ -8,31 +9,29 @@ import Control.Monad.Error
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import SourceSyntax.Pattern import qualified SourceSyntax.Annotation as A
import SourceSyntax.Location import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint import SourceSyntax.PrettyPrint (pretty)
import Text.PrettyPrint (render)
import qualified SourceSyntax.Location as Loc
import Type.Type import Type.Type
import Type.Fragment import Type.Fragment
import Type.Environment as Env import Type.Environment as Env
import qualified Type.Constrain.Literal as Literal import qualified Type.Constrain.Literal as Literal
constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
constrain env pattern tipe = constrain env pattern tipe =
let span = Loc.NoSpan (render $ pretty pattern) let region = A.None (pretty pattern)
t1 === t2 = Loc.L span (CEqual t1 t2) t1 === t2 = A.A region (CEqual t1 t2)
x <? t = Loc.L span (CInstance x t) x <? t = A.A region (CInstance x t)
in in
case pattern of case pattern of
PAnything -> return emptyFragment P.Anything -> return emptyFragment
PLiteral lit -> do P.Literal lit -> do
c <- liftIO $ Literal.constrain env span lit tipe c <- liftIO $ Literal.constrain env region lit tipe
return $ emptyFragment { typeConstraint = c } return $ emptyFragment { typeConstraint = c }
PVar name -> do P.Var name -> do
v <- liftIO $ var Flexible v <- liftIO $ var Flexible
return $ Fragment { return $ Fragment {
typeEnv = Map.singleton name (VarN v), typeEnv = Map.singleton name (VarN v),
@ -40,14 +39,14 @@ constrain env pattern tipe =
typeConstraint = VarN v === tipe typeConstraint = VarN v === tipe
} }
PAlias name p -> do P.Alias name p -> do
fragment <- constrain env p tipe fragment <- constrain env p tipe
return $ fragment { return $ fragment {
typeEnv = Map.insert name tipe (typeEnv fragment), typeEnv = Map.insert name tipe (typeEnv fragment),
typeConstraint = name <? tipe /\ typeConstraint fragment typeConstraint = name <? tipe /\ typeConstraint fragment
} }
PData name patterns -> do P.Data name patterns -> do
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
let msg = concat [ "Constructor '", name, "' expects ", show kind let msg = concat [ "Constructor '", name, "' expects ", show kind
, " argument", if kind == 1 then "" else "s" , " argument", if kind == 1 then "" else "s"
@ -63,7 +62,7 @@ constrain env pattern tipe =
vars = cvars ++ vars fragment vars = cvars ++ vars fragment
} }
PRecord fields -> do P.Record fields -> do
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
let tenv = Map.fromList (map (second VarN) pairs) let tenv = Map.fromList (map (second VarN) pairs)
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t) c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@ -73,8 +72,8 @@ constrain env pattern tipe =
typeConstraint = c typeConstraint = c
} }
instance Error (SrcSpan -> PP.Doc) where instance Error (A.Region -> PP.Doc) where
noMsg _ = PP.empty noMsg _ = PP.empty
strMsg str span = strMsg str span =
PP.vcat [ PP.text $ "Type error " ++ show span PP.vcat [ PP.text $ "Type error " ++ show span
, PP.text str ] , PP.text str ]

77
compiler/Type/ExtraChecks.hs
View file

@ -1,32 +1,35 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
{-| This module contains checks to be run *after* type inference has completed
successfully. At that point we still need to do occurs checks and ensure that
`main` has an acceptable type.
-}
module Type.ExtraChecks (mainType, occurs, portTypes) where module Type.ExtraChecks (mainType, occurs, portTypes) where
-- This module contains checks to be run *after* type inference has
-- completed successfully. At that point we still need to do occurs
-- checks and ensure that `main` has an acceptable type.
import Control.Applicative ((<$>),(<*>)) import Control.Applicative ((<$>),(<*>))
import Control.Monad.State import Control.Monad.State
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Traversable as Traverse
import qualified Data.UnionFind.IO as UF import qualified Data.UnionFind.IO as UF
import Type.Type ( Variable, structure, Term1(..), toSrcType ) import Text.PrettyPrint as P
import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.PrettyPrint as SPP
import qualified SourceSyntax.Type as ST
import qualified Transform.Expression as Expr
import qualified Type.Type as TT
import qualified Type.State as TS import qualified Type.State as TS
import qualified Type.Alias as Alias import qualified Type.Alias as Alias
import Text.PrettyPrint as P
import SourceSyntax.PrettyPrint (pretty)
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Type as T
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Location as L
import qualified Transform.Expression as Expr
import qualified Data.Traversable as Traverse
throw err = Left [ P.vcat err ] throw err = Left [ P.vcat err ]
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type)) mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
where where
mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type) mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)
mainCheck rules env = mainCheck rules env =
case Map.lookup "main" env of case Map.lookup "main" env of
Nothing -> Right env Nothing -> Right env
@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
acceptable = [ "Graphics.Element.Element" acceptable = [ "Graphics.Element.Element"
, "Signal.Signal Graphics.Element.Element" ] , "Signal.Signal Graphics.Element.Element" ]
tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)." err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
, P.text "Instead 'main' has type:\n" , P.text "Instead 'main' has type:\n"
, P.nest 4 . pretty $ Alias.realias rules mainType , P.nest 4 . SPP.pretty $ Alias.realias rules mainType
, P.text " " ] , P.text " " ]
data Direction = In | Out data Direction = In | Out
portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] () portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
portTypes rules expr = portTypes rules expr =
const () <$> Expr.checkPorts (check In) (check Out) expr const () <$> Expr.checkPorts (check In) (check Out) expr
where where
check = isValid True False False check = isValid True False False
isValid isTopLevel seenFunc seenSignal direction name tipe = isValid isTopLevel seenFunc seenSignal direction name tipe =
case tipe of case tipe of
T.Data ctor ts ST.Data ctor ts
| isJs ctor || isElm ctor -> mapM_ valid ts | isJs ctor || isElm ctor -> mapM_ valid ts
| ctor == "Signal.Signal" -> handleSignal ts | ctor == "Signal.Signal" -> handleSignal ts
| otherwise -> err' True "an unsupported type" | otherwise -> err' True "an unsupported type"
T.Var _ -> err "free type variables" ST.Var _ -> err "free type variables"
T.Lambda _ _ -> ST.Lambda _ _ ->
case direction of case direction of
In -> err "functions" In -> err "functions"
Out | seenFunc -> err "higher-order functions" Out | seenFunc -> err "higher-order functions"
| seenSignal -> err "signals that contain functions" | seenSignal -> err "signals that contain functions"
| otherwise -> | otherwise ->
forM_ (T.collectLambdas tipe) forM_ (ST.collectLambdas tipe)
(isValid' True seenSignal direction name) (isValid' True seenSignal direction name)
T.Record _ (Just _) -> err "extended records with free type variables" ST.Record _ (Just _) -> err "extended records with free type variables"
T.Record fields Nothing -> ST.Record fields Nothing ->
mapM_ (\(k,v) -> (,) k <$> valid v) fields mapM_ (\(k,v) -> (,) k <$> valid v) fields
where where
@ -100,7 +103,7 @@ portTypes rules expr =
[ txt [ "Type Error: the value ", dir "coming in" "sent out" [ txt [ "Type Error: the value ", dir "coming in" "sent out"
, " through port '", name, "' is invalid." ] , " through port '", name, "' is invalid." ]
, txt [ "It contains ", kind, ":\n" ] , txt [ "It contains ", kind, ":\n" ]
, (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n" , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
, txt [ "Acceptable values for ", dir "incoming" "outgoing" , txt [ "Acceptable values for ", dir "incoming" "outgoing"
, " ports include JavaScript values and" ] , " ports include JavaScript values and" ]
, txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ] , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
@ -112,37 +115,37 @@ portTypes rules expr =
, txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ] , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
] ]
occurs :: (String, Variable) -> StateT TS.SolverState IO () occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
occurs (name, variable) = occurs (name, variable) =
do vars <- liftIO $ infiniteVars [] variable do vars <- liftIO $ infiniteVars [] variable
case vars of case vars of
[] -> return () [] -> return ()
var:_ -> do var:_ -> do
desc <- liftIO $ UF.descriptor var desc <- liftIO $ UF.descriptor var
case structure desc of case TT.structure desc of
Nothing -> Nothing ->
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state } modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
Just _ -> Just _ ->
do liftIO $ UF.setDescriptor var (desc { structure = Nothing }) do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
var' <- liftIO $ UF.fresh desc var' <- liftIO $ UF.fresh desc
TS.addError (L.NoSpan name) (Just msg) var var' TS.addError (A.None (P.text name)) (Just msg) var var'
where where
msg = "Infinite types are not allowed" msg = "Infinite types are not allowed"
fallback _ = return $ P.text msg fallback _ = return $ P.text msg
infiniteVars :: [Variable] -> Variable -> IO [Variable] infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
infiniteVars seen var = infiniteVars seen var =
let go = infiniteVars (var:seen) in let go = infiniteVars (var:seen) in
if var `elem` seen if var `elem` seen
then return [var] then return [var]
else do else do
desc <- UF.descriptor var desc <- UF.descriptor var
case structure desc of case TT.structure desc of
Nothing -> return [] Nothing -> return []
Just struct -> Just struct ->
case struct of case struct of
App1 a b -> (++) <$> go a <*> go b TT.App1 a b -> (++) <$> go a <*> go b
Fun1 a b -> (++) <$> go a <*> go b TT.Fun1 a b -> (++) <$> go a <*> go b
Var1 a -> go a TT.Var1 a -> go a
EmptyRecord1 -> return [] TT.EmptyRecord1 -> return []
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields)) TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

25
compiler/Type/Fragment.hs
View file

@ -5,24 +5,23 @@ import qualified Data.Map as Map
import Type.Type import Type.Type
import SourceSyntax.Pattern import SourceSyntax.Pattern
import SourceSyntax.Location (noneNoDocs) import SourceSyntax.Annotation (noneNoDocs)
data Fragment = Fragment { data Fragment = Fragment
typeEnv :: Map.Map String Type, { typeEnv :: Map.Map String Type
vars :: [Variable], , vars :: [Variable]
typeConstraint :: TypeConstraint , typeConstraint :: TypeConstraint
} deriving Show } deriving Show
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue) emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
joinFragment f1 f2 = Fragment { joinFragment f1 f2 = Fragment
typeEnv = Map.union (typeEnv f1) (typeEnv f2), { typeEnv = Map.union (typeEnv f1) (typeEnv f2)
vars = vars f1 ++ vars f2, , vars = vars f1 ++ vars f2
typeConstraint = typeConstraint f1 /\ typeConstraint f2 , typeConstraint = typeConstraint f1 /\ typeConstraint f2
} }
joinFragments = List.foldl' (flip joinFragment) emptyFragment joinFragments = List.foldl' (flip joinFragment) emptyFragment
toScheme fragment = toScheme fragment =
Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment) Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

2
compiler/Type/Inference.hs
View file

@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr
import qualified Type.Solve as Solve import qualified Type.Solve as Solve
import SourceSyntax.Module as Module import SourceSyntax.Module as Module
import SourceSyntax.Location (noneNoDocs) import SourceSyntax.Annotation (noneNoDocs)
import SourceSyntax.Type (Type) import SourceSyntax.Type (Type)
import Text.PrettyPrint import Text.PrettyPrint
import qualified Type.State as TS import qualified Type.State as TS

38
compiler/Type/Solve.hs
View file

@ -3,15 +3,15 @@ module Type.Solve (solve) where
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import qualified Data.UnionFind.IO as UF import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Traversable as Traversable import qualified Data.Traversable as Traversable
import qualified Data.List as List import qualified Data.UnionFind.IO as UF
import Type.Type import Type.Type
import Type.Unify import Type.Unify
import qualified Type.ExtraChecks as Check import qualified Type.ExtraChecks as Check
import qualified Type.State as TS import qualified Type.State as TS
import SourceSyntax.Location (Located(L), SrcSpan) import qualified SourceSyntax.Annotation as A
-- | Every variable has rank less than or equal to the maxRank of the pool. -- | Every variable has rank less than or equal to the maxRank of the pool.
@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
solve :: TypeConstraint -> StateT TS.SolverState IO () solve :: TypeConstraint -> StateT TS.SolverState IO ()
solve (L span constraint) = solve (A.A region constraint) =
case constraint of case constraint of
CTrue -> return () CTrue -> return ()
@ -105,11 +105,11 @@ solve (L span constraint) =
CEqual term1 term2 -> do CEqual term1 term2 -> do
t1 <- TS.flatten term1 t1 <- TS.flatten term1
t2 <- TS.flatten term2 t2 <- TS.flatten term2
unify span t1 t2 unify region t1 t2
CAnd cs -> mapM_ solve cs CAnd cs -> mapM_ solve cs
CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
oldEnv <- TS.getEnv oldEnv <- TS.getEnv
mapM TS.introduce fqs mapM TS.introduce fqs
solve constraint' solve constraint'
@ -117,7 +117,7 @@ solve (L span constraint) =
CLet schemes constraint' -> do CLet schemes constraint' -> do
oldEnv <- TS.getEnv oldEnv <- TS.getEnv
headers <- Map.unions `fmap` mapM (solveScheme span) schemes headers <- Map.unions `fmap` mapM (solveScheme region) schemes
TS.modifyEnv $ \env -> Map.union headers env TS.modifyEnv $ \env -> Map.union headers env
solve constraint' solve constraint'
mapM Check.occurs $ Map.toList headers mapM Check.occurs $ Map.toList headers
@ -134,10 +134,10 @@ solve (L span constraint) =
error ("Could not find '" ++ name ++ "' when solving type constraints.") error ("Could not find '" ++ name ++ "' when solving type constraints.")
t <- TS.flatten term t <- TS.flatten term
unify span freshCopy t unify region freshCopy t
solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable) solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
solveScheme span scheme = solveScheme region scheme =
case scheme of case scheme of
Scheme [] [] constraint header -> do Scheme [] [] constraint header -> do
solve constraint solve constraint
@ -154,39 +154,39 @@ solveScheme span scheme =
header' <- Traversable.traverse TS.flatten header header' <- Traversable.traverse TS.flatten header
solve constraint solve constraint
allDistinct span rigidQuantifiers allDistinct region rigidQuantifiers
youngPool <- TS.getPool youngPool <- TS.getPool
TS.switchToPool oldPool TS.switchToPool oldPool
generalize youngPool generalize youngPool
mapM (isGeneric span) rigidQuantifiers mapM (isGeneric region) rigidQuantifiers
return header' return header'
-- Checks that all of the given variables belong to distinct equivalence classes. -- Checks that all of the given variables belong to distinct equivalence classes.
-- Also checks that their structure is Nothing, so they represent a variable, not -- Also checks that their structure is Nothing, so they represent a variable, not
-- a more complex term. -- a more complex term.
allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO () allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
allDistinct span vars = do allDistinct region vars = do
seen <- TS.uniqueMark seen <- TS.uniqueMark
let check var = do let check var = do
desc <- liftIO $ UF.descriptor var desc <- liftIO $ UF.descriptor var
case structure desc of case structure desc of
Just _ -> TS.addError span (Just msg) var var Just _ -> TS.addError region (Just msg) var var
where msg = "Cannot generalize something that is not a type variable." where msg = "Cannot generalize something that is not a type variable."
Nothing -> do Nothing -> do
if mark desc == seen if mark desc == seen
then let msg = "Duplicate variable during generalization." then let msg = "Duplicate variable during generalization."
in TS.addError span (Just msg) var var in TS.addError region (Just msg) var var
else return () else return ()
liftIO $ UF.setDescriptor var (desc { mark = seen }) liftIO $ UF.setDescriptor var (desc { mark = seen })
mapM_ check vars mapM_ check vars
-- Check that a variable has rank == noRank, meaning that it can be generalized. -- Check that a variable has rank == noRank, meaning that it can be generalized.
isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO () isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
isGeneric span var = do isGeneric region var = do
desc <- liftIO $ UF.descriptor var desc <- liftIO $ UF.descriptor var
if rank desc == noRank if rank desc == noRank
then return () then return ()
else let msg = "Unable to generalize a type variable. It is not unranked." else let msg = "Unable to generalize a type variable. It is not unranked."
in TS.addError span (Just msg) var var in TS.addError region (Just msg) var var

32
compiler/Type/State.hs
View file

@ -1,16 +1,17 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Type.State where module Type.State where
import Type.Type
import qualified Data.Map as Map
import qualified Data.UnionFind.IO as UF
import Control.Monad.State
import Control.Applicative ((<$>),(<*>), Applicative) import Control.Applicative ((<$>),(<*>), Applicative)
import Control.Monad.State
import qualified Data.Map as Map
import qualified Data.Traversable as Traversable import qualified Data.Traversable as Traversable
import Text.PrettyPrint as P import qualified Data.UnionFind.IO as UF
import qualified SourceSyntax.Annotation as A
import SourceSyntax.PrettyPrint import SourceSyntax.PrettyPrint
import SourceSyntax.Location import Text.PrettyPrint as P
import qualified Type.Alias as Alias import qualified Type.Alias as Alias
import Type.Type
-- Pool -- Pool
-- Holds a bunch of variables -- Holds a bunch of variables
@ -46,7 +47,7 @@ initialState = SS {
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) } modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
modifyPool f = modify $ \state -> state { sPool = f (sPool state) } modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
addError span hint t1 t2 = addError region hint t1 t2 =
modify $ \state -> state { sErrors = makeError : sErrors state } modify $ \state -> state { sErrors = makeError : sErrors state }
where where
makeError rules = do makeError rules = do
@ -54,24 +55,15 @@ addError span hint t1 t2 =
t1' <- prettiest <$> toSrcType t1 t1' <- prettiest <$> toSrcType t1
t2' <- prettiest <$> toSrcType t2 t2' <- prettiest <$> toSrcType t2
return . P.vcat $ return . P.vcat $
[ P.text $ "Type error" ++ location ++ ":" [ P.text "Type error" <+> pretty region <> P.colon
, maybe P.empty P.text hint , maybe P.empty P.text hint
, display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg } , P.text ""
, P.nest 8 $ A.getRegionDocs region
, P.text ""
, P.text " Expected Type:" <+> t1' , P.text " Expected Type:" <+> t1'
, P.text " Actual Type:" <+> t2' , P.text " Actual Type:" <+> t2'
] ]
location = case span of
NoSpan _ -> ""
Span p1 p2 _ ->
if line p1 == line p2 then " on line " ++ show (line p1)
else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
display msg =
P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
, P.text " " ]
switchToPool pool = modifyPool (\_ -> pool) switchToPool pool = modifyPool (\_ -> pool)
getPool :: StateT SolverState IO Pool getPool :: StateT SolverState IO Pool

26
compiler/Type/Type.hs
View file

@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
import Control.Monad.State import Control.Monad.State
import Control.Monad.Error import Control.Monad.Error
import Data.Traversable (traverse) import Data.Traversable (traverse)
import SourceSyntax.Location import SourceSyntax.Annotation
import SourceSyntax.Helpers (isTuple) import SourceSyntax.Helpers (isTuple)
import qualified SourceSyntax.Type as Src import qualified SourceSyntax.Type as Src
@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
infixl 8 /\ infixl 8 /\
(/\) :: Constraint a b -> Constraint a b -> Constraint a b (/\) :: Constraint a b -> Constraint a b -> Constraint a b
a@(L _ c1) /\ b@(L _ c2) = a@(A _ c1) /\ b@(A _ c2) =
case (c1, c2) of case (c1, c2) of
(CTrue, _) -> b (CTrue, _) -> b
(_, CTrue) -> a (_, CTrue) -> a
@ -128,11 +128,13 @@ structuredVar structure = UF.fresh $ Descriptor {
-- ex qs constraint == exists qs. constraint -- ex qs constraint == exists qs. constraint
ex :: [Variable] -> TypeConstraint -> TypeConstraint ex :: [Variable] -> TypeConstraint -> TypeConstraint
ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue) ex fqs constraint@(A ann _) =
A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
-- fl qs constraint == forall qs. constraint -- fl qs constraint == forall qs. constraint
fl :: [Variable] -> TypeConstraint -> TypeConstraint fl :: [Variable] -> TypeConstraint -> TypeConstraint
fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue) fl rqs constraint@(A ann _) =
A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
exists f = do exists f = do
@ -148,8 +150,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point) pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
instance PrettyType a => PrettyType (Located a) where instance PrettyType t => PrettyType (Annotated a t) where
pretty when (L _ e) = pretty when e pretty when (A _ e) = pretty when e
instance PrettyType a => PrettyType (Term1 a) where instance PrettyType a => PrettyType (Term1 a) where
@ -212,12 +214,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
CAnd cs -> CAnd cs ->
P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs) P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header -> CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
P.sep [ binder, pretty Never c ] P.sep [ binder, pretty Never c ]
where where
mergeExists vs (L _ c) = mergeExists vs (A _ c) =
case c of case c of
CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c' CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
_ -> (vs, c) _ -> (vs, c)
(fqs', c) = mergeExists fqs constraint (fqs', c) = mergeExists fqs constraint
@ -233,7 +235,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
P.text name <+> P.text "<" <+> prty tipe P.text name <+> P.text "<" <+> prty tipe
instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
pretty _ (Scheme rqs fqs (L _ constraint) headers) = pretty _ (Scheme rqs fqs (A _ constraint) headers) =
P.sep [ forall, cs, headers' ] P.sep [ forall, cs, headers' ]
where where
prty = pretty Never prty = pretty Never
@ -297,8 +299,8 @@ class Crawl t where
-> t -> t
-> StateT CrawlState IO t -> StateT CrawlState IO t
instance Crawl a => Crawl (Located a) where instance Crawl e => Crawl (Annotated a e) where
crawl nextState (L s e) = L s <$> crawl nextState e crawl nextState (A ann e) = A ann <$> crawl nextState e
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
crawl nextState constraint = crawl nextState constraint =

30
compiler/Type/Unify.hs
View file

@ -1,27 +1,27 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Type.Unify (unify) where module Type.Unify (unify) where
import Type.Type import Control.Monad.State
import qualified Data.UnionFind.IO as UF
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe as Maybe import qualified Data.Maybe as Maybe
import qualified Data.UnionFind.IO as UF
import qualified SourceSyntax.Annotation as A
import qualified Type.State as TS import qualified Type.State as TS
import Control.Monad.State import Type.Type
import SourceSyntax.Location
import Type.PrettyPrint import Type.PrettyPrint
import Text.PrettyPrint (render) import Text.PrettyPrint (render)
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO () unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
unify span variable1 variable2 = do unify region variable1 variable2 = do
equivalent <- liftIO $ UF.equivalent variable1 variable2 equivalent <- liftIO $ UF.equivalent variable1 variable2
if equivalent then return () if equivalent then return ()
else actuallyUnify span variable1 variable2 else actuallyUnify region variable1 variable2
actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO () actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
actuallyUnify span variable1 variable2 = do actuallyUnify region variable1 variable2 = do
desc1 <- liftIO $ UF.descriptor variable1 desc1 <- liftIO $ UF.descriptor variable1
desc2 <- liftIO $ UF.descriptor variable2 desc2 <- liftIO $ UF.descriptor variable2
let unify' = unify span let unify' = unify region
name' :: Maybe String name' :: Maybe String
name' = case (name desc1, name desc2) of name' = case (name desc1, name desc2) of
@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
unifyNumber svar name unifyNumber svar name
| name `elem` ["Int","Float","number"] = flexAndUnify svar | name `elem` ["Int","Float","number"] = flexAndUnify svar
| otherwise = TS.addError span (Just hint) variable1 variable2 | otherwise = TS.addError region (Just hint) variable1 variable2
where hint = "A number must be an Int or Float." where hint = "A number must be an Int or Float."
comparableError maybe = comparableError maybe =
TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
where msg = "A comparable must be an Int, Float, Char, String, list, or tuple." where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
unifyComparable var name unifyComparable var name
@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
List _ -> flexAndUnify varSuper List _ -> flexAndUnify varSuper
_ -> comparableError Nothing _ -> comparableError Nothing
rigidError variable = TS.addError span (Just hint) variable1 variable2 rigidError variable = TS.addError region (Just hint) variable1 variable2
where where
var = "'" ++ render (pretty Never variable) ++ "'" var = "'" ++ render (pretty Never variable) ++ "'"
hint = "Cannot unify rigid type variable " ++ var ++ hint = "Cannot unify rigid type variable " ++ var ++
@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
(Rigid, _, _, _) -> rigidError variable1 (Rigid, _, _, _) -> rigidError variable1
(_, Rigid, _, _) -> rigidError variable2 (_, Rigid, _, _) -> rigidError variable2
_ -> TS.addError span Nothing variable1 variable2 _ -> TS.addError region Nothing variable1 variable2
case (structure desc1, structure desc2) of case (structure desc1, structure desc2) of
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
eat (_:xs) (_:ys) = eat xs ys eat (_:xs) (_:ys) = eat xs ys
eat xs _ = xs eat xs _ = xs
_ -> TS.addError span Nothing variable1 variable2 _ -> TS.addError region Nothing variable1 variable2