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

63
compiler/Generate/Cases.hs
View file

@ -6,14 +6,15 @@ import Control.Monad.State
import Data.List (groupBy,sortBy)
import Data.Maybe (fromMaybe)
import SourceSyntax.Location
import SourceSyntax.Literal
import SourceSyntax.Pattern
import SourceSyntax.Annotation
import SourceSyntax.Expression
import SourceSyntax.Literal
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as V
import Transform.Substitute
toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
toMatch patterns = do
v <- newVar
(,) v <$> match [v] (map (first (:[])) patterns) Fail
@ -27,7 +28,7 @@ data Match
= Match String [Clause] Match
| Break
| Fail
| Other LExpr
| Other Expr
| Seq [Match]
deriving Show
@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
matchSubst _ Break = Break
matchSubst _ Fail = Fail
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
matchSubst pairs (Other (L s e)) =
Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
matchSubst pairs (Other (A a e)) =
Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
matchSubst pairs (Match n cs m) =
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
where varSubst v = fromMaybe v (lookup v pairs)
@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
isCon (p:_, _) =
case p of
PData _ _ -> True
PLiteral _ -> True
_ -> False
P.Data _ _ -> True
P.Literal _ -> True
_ -> False
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 [] [([],e)] Fail = return $ Other e
match [] [([],e)] Break = return $ Other e
@ -67,46 +68,46 @@ match vs@(v:_) cs def
where
cs' = map (dealias v) cs
dealias v c@(p:ps, L s e) =
dealias v c@(p:ps, A a e) =
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
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
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
subOnePattern pattern e =
case pattern of
PVar x -> subst x (Var v) e
PAnything -> e
PRecord fs ->
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
P.Var x -> subst x (rawVar v) e
P.Anything -> e
P.Record 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
where
css = groupBy eq (sortBy cmp cs)
cmp (p1:_,_) (p2:_,_) =
case (p1,p2) of
(PData n1 _, PData n2 _) -> compare n1 n2
(P.Data n1 _, P.Data n2 _) -> compare n1 n2
_ -> compare p1 p2
eq (p1:_,_) (p2:_,_) =
case (p1,p2) of
(PData n1 _, PData n2 _) -> n1 == n2
(P.Data n1 _, P.Data n2 _) -> n1 == n2
_ -> p1 == p2
toClause cs =
case head cs of
(PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
(PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
(P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
(P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
matchClause :: Either String Literal
-> [String]
-> [([Pattern],LExpr)]
-> [([P.Pattern],Expr)]
-> Match
-> State Int Clause
matchClause c (_:vs) cs def =
@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
flatten (p:ps, e) =
case p of
PData _ ps' -> (ps' ++ ps, e)
PLiteral _ -> (ps, e)
P.Data _ ps' -> (ps' ++ ps, e)
P.Literal _ -> (ps, e)
getVars =
case head cs of
(PData _ ps : _, _) -> forM ps (const newVar)
(PLiteral _ : _, _) -> return []
(P.Data _ ps : _, _) -> forM ps (const newVar)
(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)
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 #-}
module Generate.JavaScript (generate) where
import Control.Arrow (first,(***))
import Control.Applicative ((<$>),(<*>))
import Control.Arrow (first,(***))
import Control.Monad.State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Language.ECMAScript3.PrettyPrint
import Language.ECMAScript3.Syntax
import Generate.JavaScript.Helpers
import qualified Generate.Cases as Case
import qualified Generate.JavaScript.Ports as Port
import qualified Generate.Markdown as MD
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Helpers as Help
import SourceSyntax.Literal
import SourceSyntax.Pattern as Pattern
import SourceSyntax.Location
import SourceSyntax.Expression
import SourceSyntax.Module
import Language.ECMAScript3.Syntax
import Language.ECMAScript3.PrettyPrint
import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint (renderPretty)
import qualified SourceSyntax.Variable as V
import qualified Transform.SafeNames as MakeSafe
varDecl :: String -> Expression () -> VarDecl ()
@ -50,10 +52,10 @@ literal lit =
FloatNum n -> NumLit () n
Boolean b -> BoolLit () b
expression :: LExpr -> State Int (Expression ())
expression (L span expr) =
expression :: Expr -> State Int (Expression ())
expression (A region expr) =
case expr of
Var x -> return $ ref x
Var (V.Raw x) -> return $ ref x
Literal lit -> return $ literal lit
Range lo hi ->
@ -93,9 +95,9 @@ expression (L span expr) =
Map.toList . Map.filter (not . null) $ Map.map tail 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)
body' <- expression body
return $ case length args < 2 || length args > 9 of
@ -104,13 +106,14 @@ expression (L span expr) =
where
depattern (args, body) pattern =
case pattern of
PVar x -> return (args ++ [x], body)
P.Var x -> return (args ++ [x], body)
_ -> 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
collect patterns lexpr@(L _ expr) =
collect patterns lexpr@(A _ expr) =
case expr of
Lambda p e -> collect (p:patterns) e
_ -> (patterns, lexpr)
@ -127,7 +130,7 @@ expression (L span expr) =
(func, args) = getArgs e1 [e2]
getArgs func args =
case func of
(L _ (App f arg)) -> getArgs f (arg : args)
(A _ (App f arg)) -> getArgs f (arg : args)
_ -> (func, args)
Let defs e ->
@ -139,9 +142,9 @@ expression (L span expr) =
MultiIf branches ->
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
return $ case last branches of
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
(L _ (Literal (Boolean True)), _) -> safeIfs branches'
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
(A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
(A _ (Literal (Boolean True)), _) -> safeIfs branches'
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
where
safeIfs branches = ifs (init branches) (snd (last branches))
ifs branches finally = foldr iff finally branches
@ -151,10 +154,12 @@ expression (L span expr) =
do (tempVar,initialMatch) <- Case.toMatch cases
(revisedMatch, stmt) <-
case e of
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
_ -> do e' <- expression e
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
match' <- match span revisedMatch
A _ (Var (V.Raw x)) ->
return (Case.matchSubst [(tempVar,x)] initialMatch, [])
_ ->
do e' <- expression e
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
match' <- match region revisedMatch
return (function [] (stmt ++ match') `call` [])
ExplicitList es ->
@ -184,28 +189,28 @@ expression (L span expr) =
[ string name, Port.outgoing tipe, value' ]
definition :: Def -> State Int [Statement ()]
definition (Definition pattern expr@(L span _) _) = do
definition (Definition pattern expr@(A region _) _) = do
expr' <- expression expr
let assign x = varDecl x expr'
case pattern of
PVar x
P.Var x
| Help.isOp x ->
let op = LBracket () (ref "_op") (string x) in
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
| otherwise ->
return [ VarDeclStmt () [ assign x ] ]
PRecord fields ->
P.Record fields ->
let setField f = varDecl f (dotSep ["$",f]) in
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..])) ]
where
vars = getVars patterns
getVars patterns =
case patterns of
PVar x : rest -> (x:) `fmap` getVars rest
P.Var x : rest -> (x:) `fmap` getVars rest
[] -> Just []
_ -> Nothing
@ -216,23 +221,23 @@ definition (Definition pattern expr@(L span _) _) = do
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
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
return (VarDeclStmt () [assign "$"] : defs')
where
vars = Set.toList $ Pattern.boundVars pattern
mkVar = L span . Var
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (PVar y) expr Nothing
vars = P.boundVarList pattern
mkVar = A region . rawVar
toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (P.Var y) expr Nothing
match :: SrcSpan -> Case.Match -> State Int [Statement ()]
match span mtch =
match :: Region -> Case.Match -> State Int [Statement ()]
match region mtch =
case mtch of
Case.Match name clauses mtch' ->
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
mtch'' <- match span mtch'
do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
mtch'' <- match region mtch'
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
where
isLiteral p = case p of
@ -244,13 +249,13 @@ match span mtch =
| otherwise = e
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.Other e ->
do e' <- expression e
return [ ret e' ]
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
where
dropEnd acc [] = acc
dropEnd acc (m:ms) =
@ -258,9 +263,9 @@ match span mtch =
Case.Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause span variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause region variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
where
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
(isChar, pattern) =
@ -273,8 +278,8 @@ clause span variable (Case.Clause value vars mtch) =
[] -> name
is -> drop (last is + 1) name
flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
flattenLets defs lexpr@(L _ expr) =
flattenLets :: [Def] -> Expr -> ([Def], Expr)
flattenLets defs lexpr@(A _ expr) =
case expr of
Let ds body -> flattenLets (defs ++ ds) body
_ -> (defs, lexpr)
@ -321,8 +326,8 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
binop span op e1 e2 =
binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
binop region op e1 e2 =
case op of
"Basics.." ->
do es <- mapM expression (e1 : collect [] e2)
@ -335,7 +340,7 @@ binop span op e1 e2 =
do e1' <- expression e1
e2' <- expression e2
return $ obj "_L.append" `call` [e1', e2']
"::" -> expression (L span (Data "::" [e1,e2]))
"::" -> expression (A region (Data "::" [e1,e2]))
_ ->
do e1' <- expression e1
e2' <- expression e2
@ -345,7 +350,7 @@ binop span op e1 e2 =
where
collect es e =
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]
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
import Control.Applicative ((<$>))
import Data.List (intercalate)
import qualified Data.List as List
import qualified Data.Map as Map
import SourceSyntax.Location (merge)
import SourceSyntax.Annotation (merge)
import qualified SourceSyntax.Expression as E
import SourceSyntax.Declaration (Assoc(..))
import Text.Parsec
@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
opAssoc :: OpTable -> String -> Assoc
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
binops :: IParser E.LParseExpr
-> IParser E.LParseExpr
binops :: IParser E.ParseExpr
-> IParser E.ParseExpr
-> IParser String
-> IParser E.LParseExpr
-> IParser E.ParseExpr
binops term last anyOp =
do e <- term
table <- getState
@ -38,9 +39,9 @@ binops term last anyOp =
split :: OpTable
-> Int
-> E.LParseExpr
-> [(String, E.LParseExpr)]
-> IParser E.LParseExpr
-> E.ParseExpr
-> [(String, E.ParseExpr)]
-> IParser E.ParseExpr
split _ _ e [] = return e
split table n e eops = do
assoc <- getAssoc table n eops
@ -49,26 +50,26 @@ split table n e eops = do
case assoc of R -> joinR es ops
_ -> joinL es ops
splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
-> [IParser E.LParseExpr]
splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
-> [IParser E.ParseExpr]
splitLevel table n e eops =
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
(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 (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."
joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
return (merge a e (E.Binop op a e))
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
| all (==L) assocs = return L
| all (==R) assocs = return R
@ -79,5 +80,5 @@ getAssoc table n eops
assocs = map (opAssoc table . fst) levelOps
msg problem =
concat [ "Conflicting " ++ problem ++ " for binary operators ("
, intercalate ", " (map fst eops), "). "
, List.intercalate ", " (map fst eops), "). "
, "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.Indent
import Parse.Binop
import Parse.Helpers
import Parse.Literal
import qualified Parse.Pattern as Pattern
import qualified Parse.Type as Type
import Parse.Binop
import Parse.Literal
import SourceSyntax.Location as Location
import SourceSyntax.Pattern hiding (tuple,list)
import qualified SourceSyntax.Literal as Literal
import SourceSyntax.Annotation as Annotation
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Literal as L
import SourceSyntax.Expression
-------- Basic Terms --------
varTerm :: IParser ParseExpr
varTerm :: IParser ParseExpr'
varTerm = toVar <$> var <?> "variable"
toVar :: String -> ParseExpr
toVar v = case v of "True" -> Literal (Literal.Boolean True)
"False" -> Literal (Literal.Boolean False)
_ -> Var v
toVar :: String -> ParseExpr'
toVar v = case v of "True" -> Literal (L.Boolean True)
"False" -> Literal (L.Boolean False)
_ -> rawVar v
accessor :: IParser ParseExpr
accessor :: IParser ParseExpr'
accessor = do
(start, lbl, end) <- located (try (string "." >> rLabel))
let loc e = Location.at start end e
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
let loc e = Annotation.at start end e
return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
negative :: IParser ParseExpr
negative :: IParser ParseExpr'
negative = do
(start, nTerm, end) <-
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
let loc e = Location.at start end e
return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
let loc e = Annotation.at start end e
return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
-------- Complex Terms --------
listTerm :: IParser ParseExpr
listTerm :: IParser ParseExpr'
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
where
range = do
@ -66,86 +66,87 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
string "}}"
return (span uid (length exprs), exprs ++ [e])
parensTerm :: IParser LParseExpr
parensTerm :: IParser ParseExpr
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
where
opFn = do
(start, op, end) <- located anyOp
let loc = Location.at start end
return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
Binop op (loc $ Var "x") (loc $ Var "y")
let loc = Annotation.at start end
return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
Binop op (loc $ rawVar "x") (loc $ rawVar "y")
tupleFn = do
let comma = char ',' <?> "comma ','"
(start, commas, end) <- located (comma >> many (whitespace >> comma))
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)
(loc . tuple $ map (loc . Var) vars) (map PVar vars)
(loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
parened = do
(start, es, end) <- located (commaSep expr)
return $ case es of
[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 ]
where field = do
label <- rLabel
patterns <- spacePrefix Pattern.term
padded equals
body <- expr
return (label, makeFunction patterns body)
where
field = do
label <- rLabel
patterns <- spacePrefix Pattern.term
padded equals
body <- expr
return (label, makeFunction patterns body)
record = Record <$> commaSep field
record = Record <$> commaSep field
change = do
lbl <- rLabel
padded (string "<-")
(,) lbl <$> expr
change = do
lbl <- rLabel
padded (string "<-")
(,) lbl <$> expr
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
insert r = addLocation $ do
string "|" >> whitespace
Insert r <$> rLabel <*> (padded equals >> expr)
insert r = addLocation $ do
string "|" >> whitespace
Insert r <$> rLabel <*> (padded equals >> expr)
modify r = addLocation
(string "|" >> whitespace >> Modify r <$> commaSep1 change)
modify r =
addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
misc = try $ do
record <- addLocation (Var <$> rLabel)
opt <- padded (optionMaybe (remove record))
case opt of
Just e -> try (insert e) <|> return e
Nothing -> try (insert record) <|> try (modify record)
misc = try $ do
record <- addLocation (rawVar <$> rLabel)
opt <- padded (optionMaybe (remove record))
case opt of
Just e -> try (insert e) <|> return e
Nothing -> try (insert record) <|> try (modify record)
term :: IParser LParseExpr
term :: IParser ParseExpr
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
<?> "basic term (4, x, 'c', etc.)"
-------- Applications --------
appExpr :: IParser LParseExpr
appExpr :: IParser ParseExpr
appExpr = do
t <- term
ts <- constrainedSpacePrefix term $ \str ->
if null str then notFollowedBy (char '-') else return ()
return $ case ts of
[] -> 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 --------
binaryExpr :: IParser LParseExpr
binaryExpr :: IParser ParseExpr
binaryExpr = binops appExpr lastExpr anyOp
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
ifExpr :: IParser ParseExpr
ifExpr :: IParser ParseExpr'
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
where
normal = do
@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
elseBranch <- expr
return $ MultiIf [(bool, thenBranch),
(Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
(Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
multiIf = MultiIf <$> spaceSep1 iff
where iff = do string "|" ; whitespace
b <- expr ; padded arrow
(,) b <$> expr
lambdaExpr :: IParser LParseExpr
lambdaExpr :: IParser ParseExpr
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
whitespace
args <- spaceSep1 Pattern.term
@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
defSet :: IParser [ParseDef]
defSet = block (do d <- def ; whitespace ; return d)
letExpr :: IParser ParseExpr
letExpr :: IParser ParseExpr'
letExpr = do
reserved "let" ; whitespace
defs <- defSet
padded (reserved "in")
Let defs <$> expr
caseExpr :: IParser ParseExpr
caseExpr :: IParser ParseExpr'
caseExpr = do
reserved "case"; e <- padded expr; reserved "of"; whitespace
Case e <$> (with <|> without)
@ -189,35 +190,35 @@ caseExpr = do
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
without = block (do c <- case_ ; whitespace ; return c)
expr :: IParser LParseExpr
expr :: IParser ParseExpr
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
<|> binaryExpr
<?> "an expression"
defStart :: IParser [Pattern]
defStart :: IParser [P.Pattern]
defStart =
choice [ do p1 <- try Pattern.term
infics p1 <|> func p1
, func =<< (PVar <$> parens symOp)
, func =<< (P.Var <$> parens symOp)
, (:[]) <$> Pattern.expr
] <?> "the definition of a variable (x = ...)"
where
func pattern =
case pattern of
PVar _ -> (pattern:) <$> spacePrefix Pattern.term
P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
_ -> do try (lookAhead (whitespace >> string "="))
return [pattern]
infics p1 = do
o:p <- try (whitespace >> anyOp)
p2 <- (whitespace >> Pattern.term)
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
else [ PVar (o:p), p1, p2 ]
return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
else [ P.Var (o:p), p1, p2 ]
makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
makeFunction args body@(L s _) =
foldr (\arg body' -> L s $ Lambda arg body') body args
makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
makeFunction args body@(A ann _) =
foldr (\arg body' -> A ann $ Lambda arg body') body args
definition :: IParser ParseDef
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 qualified Text.Parsec.Token as T
import SourceSyntax.Helpers as Help
import SourceSyntax.Location as Location
import SourceSyntax.Expression
import SourceSyntax.PrettyPrint
import SourceSyntax.Annotation as Annotation
import SourceSyntax.Declaration (Assoc)
import SourceSyntax.Expression
import SourceSyntax.Helpers as Help
import SourceSyntax.PrettyPrint
import SourceSyntax.Variable as Variable
reserveds = [ "if", "then", "else"
, "case", "of"
@ -181,10 +182,10 @@ parens = surround '(' ')' "paren"
brackets :: IParser a -> IParser a
brackets = surround '{' '}' "bracket"
addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
addLocation expr = do
(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 p = do
@ -193,10 +194,10 @@ located p = do
end <- getPosition
return (start, e, end)
accessible :: IParser LParseExpr -> IParser LParseExpr
accessible :: IParser ParseExpr -> IParser ParseExpr
accessible expr = do
start <- getPosition
ce@(L _ e) <- expr
ce@(A _ e) <- expr
let rest f = do
let dot = char '.' >> notFollowedBy (char '.')
access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@ -205,10 +206,12 @@ accessible expr = do
Just _ -> accessible $ do
v <- var <?> "field access (e.g. List.map)"
end <- getPosition
return (Location.at start end (f v))
case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
| otherwise -> rest (Access ce)
_ -> rest (Access ce)
return (Annotation.at start end (f v))
case e of
Var (Variable.Raw (c:cs))
| isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
| otherwise -> rest (Access ce)
_ -> rest (Access ce)
spaces :: IParser String

56
compiler/Parse/Pattern.hs
View file

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

150
compiler/SourceSyntax/Expression.hs
View file

@ -11,49 +11,54 @@ module SourceSyntax.Expression where
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
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.Type as SrcType
import qualified SourceSyntax.Literal as Literal
import qualified SourceSyntax.Variable as Variable
---- 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
"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
structural changes in the types. The only type hole right now is:
move through the compilation process. The type holes are used to represent:
def: Parsing allows two kinds of definitions (type annotations or definitions),
but later checks will see that they are well formed and combine them.
ann: Annotations for arbitrary expressions. Allows you to add information
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
| Var String
| Range (LExpr' def) (LExpr' def)
| ExplicitList [LExpr' def]
| Binop String (LExpr' def) (LExpr' def)
| Lambda Pattern.Pattern (LExpr' def)
| App (LExpr' def) (LExpr' def)
| MultiIf [(LExpr' def,LExpr' def)]
| Let [def] (LExpr' def)
| Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
| Data String [LExpr' def]
| Access (LExpr' def) String
| Remove (LExpr' def) String
| Insert (LExpr' def) String (LExpr' def)
| Modify (LExpr' def) [(String, LExpr' def)]
| Record [(String, LExpr' def)]
| Markdown String String [LExpr' def]
| Var var
| Range (GeneralExpr ann def var) (GeneralExpr ann def var)
| ExplicitList [GeneralExpr ann def var]
| Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
| Lambda Pattern.Pattern (GeneralExpr ann def var)
| App (GeneralExpr ann def var) (GeneralExpr ann def var)
| MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
| Let [def] (GeneralExpr ann def var)
| Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
| Data String [GeneralExpr ann def var]
| Access (GeneralExpr ann def var) String
| Remove (GeneralExpr ann def var) String
| Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
| Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
| Record [(String, GeneralExpr ann def var)]
| Markdown String String [GeneralExpr ann def var]
-- for type checking and code gen only
| PortIn String SrcType.Type
| PortOut String SrcType.Type (LExpr' def)
| PortOut String SrcType.Type (GeneralExpr ann def var)
deriving (Show)
---- SPECIALIZED ASTs ----
@ -62,81 +67,100 @@ data Expr' def
annotations and definitions, which is how they appear in source code and how
they are parsed.
-}
type ParseExpr = Expr' ParseDef
type LParseExpr = LExpr' ParseDef
type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
data ParseDef
= Def Pattern.Pattern LParseExpr
= Def Pattern.Pattern ParseExpr
| TypeAnnotation String SrcType.Type
deriving (Show)
deriving (Show)
{-| "Normal" expressions. When the compiler checks that type annotations and
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.
-}
type LExpr = LExpr' Def
type Expr = Expr' Def
type Expr = GeneralExpr Annotation.Region Def Variable.Raw
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)
---- 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
delist :: LExpr' def -> [LExpr' def]
delist (Location.L _ (Data "::" [h,t])) = h : delist t
delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
delist _ = []
saveEnvName :: String
saveEnvName = "_save_the_environment!!!"
dummyLet :: Pretty def => [def] -> LExpr' def
dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
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
show = render . pretty
instance Pretty def => Pretty (Expr' def) where
instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
pretty expr =
case expr of
Literal lit -> pretty lit
Var x -> variable x
Var x -> pretty x
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
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
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
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)
App _ _ -> P.hang func 2 (P.sep args)
where func:args = map prettyParens (collectApps (Location.none expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
where
func:args = map prettyParens (collectApps (Annotation.A undefined expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
where
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
Let defs e ->
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
, P.text "in" <+> pretty e ]
Case e pats ->
P.hang pexpr 2 (P.vcat (map pretty' pats))
where
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
Data "[]" [] -> P.text "[]"
Data name es
| Help.isTuple name -> P.parens (commaCat (map pretty es))
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
Access e x -> prettyParens 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 ->
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
@ -175,21 +199,23 @@ instance Pretty Def where
Nothing -> P.empty
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
collectApps :: LExpr' def -> [LExpr' def]
collectApps lexpr@(Location.L _ expr) =
collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
collectApps annExpr@(Annotation.A _ expr) =
case expr of
App a b -> collectApps a ++ [b]
_ -> [lexpr]
_ -> [annExpr]
collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
collectLambdas lexpr@(Location.L _ expr) =
collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
collectLambdas lexpr@(Annotation.A _ expr) =
case expr of
Lambda pattern body -> (pattern : ps, body')
where (ps, body') = collectLambdas body
Lambda pattern body ->
let (ps, body') = collectLambdas body
in (pattern : ps, body')
_ -> ([], lexpr)
prettyParens :: (Pretty def) => LExpr' def -> Doc
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
where
needed =
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 Text.PrettyPrint as P
import SourceSyntax.Expression (LExpr)
import SourceSyntax.Expression (Expr)
import SourceSyntax.Declaration
import SourceSyntax.PrettyPrint
import SourceSyntax.Type
@ -72,7 +72,7 @@ data MetadataModule =
, path :: FilePath
, exports :: [String]
, imports :: [(String, ImportMethod)]
, program :: LExpr
, program :: Expr
, types :: Map.Map String Type
, fixities :: [(Assoc, Int, String)]
, 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 SourceSyntax.Literal as Literal
data Pattern = PData String [Pattern]
| PRecord [String]
| PAlias String Pattern
| PVar String
| PAnything
| PLiteral Literal.Literal
deriving (Eq, Ord, Show)
data Pattern
= Data String [Pattern]
| Record [String]
| Alias String Pattern
| Var String
| Anything
| Literal Literal.Literal
deriving (Eq, Ord, Show)
cons :: Pattern -> Pattern -> Pattern
cons h t = PData "::" [h,t]
cons h t = Data "::" [h,t]
nil :: Pattern
nil = PData "[]" []
nil = Data "[]" []
list :: [Pattern] -> Pattern
list = foldr cons nil
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 =
case pattern of
PVar x -> Set.singleton x
PAlias x p -> Set.insert x (boundVars p)
PData _ ps -> Set.unions (map boundVars ps)
PRecord fields -> Set.fromList fields
PAnything -> Set.empty
PLiteral _ -> Set.empty
Var x -> Set.singleton x
Alias x p -> Set.insert x (boundVars p)
Data _ ps -> Set.unions (map boundVars ps)
Record fields -> Set.fromList fields
Anything -> Set.empty
Literal _ -> Set.empty
instance Pretty Pattern where
pretty pattern =
case pattern of
PVar x -> variable x
PLiteral lit -> pretty lit
PRecord fs -> PP.braces (commaCat $ map variable fs)
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
PAnything -> PP.text "_"
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
Var x -> variable x
Literal lit -> pretty lit
Record fs -> PP.braces (commaCat $ map variable fs)
Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
Anything -> PP.text "_"
Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
where isCons = case hd of
PData "::" _ -> True
Data "::" _ -> True
_ -> False
PData name ps ->
Data name ps ->
if Help.isTuple name then
PP.parens . commaCat $ map pretty ps
else hsep (PP.text name : map prettyParens ps)
@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
where
needsThem =
case pattern of
PData name (_:_) | not (Help.isTuple name) -> True
PAlias _ _ -> True
Data name (_:_) | not (Help.isTuple name) -> True
Alias _ _ -> True
_ -> False

5
compiler/SourceSyntax/PrettyPrint.hs
View file

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

9
compiler/SourceSyntax/Type.hs
View file

@ -1,18 +1,18 @@
{-# OPTIONS_GHC -W #-}
module SourceSyntax.Type where
import Control.Applicative ((<$>), (<*>))
import Data.Binary
import qualified Data.Map as Map
import qualified SourceSyntax.Helpers as Help
import Control.Applicative ((<$>), (<*>))
import SourceSyntax.PrettyPrint
import qualified SourceSyntax.Helpers as Help
import Text.PrettyPrint as P
data Type = Lambda Type Type
| Var String
| Data String [Type]
| Record [(String,Type)] (Maybe String)
deriving (Eq)
deriving (Eq,Show)
fieldMap :: [(String,a)] -> Map.Map String [a]
fieldMap fields =
@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
tupleOf :: [Type] -> Type
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
instance Show Type where
show = render . pretty
instance Pretty Type where
pretty tipe =
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
import Control.Arrow ((***))
import Control.Applicative (Applicative,(<$>),(<*>))
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.Set as Set
import qualified Data.List as List
import qualified Data.Either as Either
import SourceSyntax.Module
import qualified Data.Traversable as T
import SourceSyntax.Annotation as A
import SourceSyntax.Expression
import SourceSyntax.Location as Loc
import SourceSyntax.Module
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as Type
import qualified SourceSyntax.Variable as Var
import Text.PrettyPrint as P
interface :: String -> ModuleInterface -> ModuleInterface
@ -96,8 +97,7 @@ type Env = Map.Map String String
extend :: Env -> P.Pattern -> 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 variable env v =
@ -110,14 +110,15 @@ replace variable env v =
msg = if null matches then "" else
"\nClose matches include: " ++ List.intercalate ", " matches
rename :: Env -> LExpr -> Either [Doc] LExpr
rename env (L s expr) =
-- TODO: Var.Raw -> Var.Canonical
rename :: Env -> Expr -> Either [Doc] Expr
rename env (A ann expr) =
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
renameType' env = renameType (format . replace "variable" env)
renameType' environ = renameType (format . replace "variable" environ)
in
L s <$>
A ann <$>
case expr of
Literal _ -> return expr
@ -155,7 +156,8 @@ rename env (L s expr) =
<*> rename env' body
<*> 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
@ -176,10 +178,10 @@ rename env (L s expr) =
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
renamePattern env pattern =
case pattern of
P.PVar _ -> return pattern
P.PLiteral _ -> return pattern
P.PRecord _ -> return pattern
P.PAnything -> return pattern
P.PAlias x p -> P.PAlias x <$> renamePattern env p
P.PData name ps -> P.PData <$> replace "pattern" env name
<*> mapM (renamePattern env) ps
P.Var _ -> return pattern
P.Literal _ -> return pattern
P.Record _ -> return pattern
P.Anything -> return pattern
P.Alias x p -> P.Alias x <$> renamePattern env p
P.Data name ps -> P.Data <$> replace "pattern" env name
<*> mapM (renamePattern env) ps

2
compiler/Transform/Declaration.hs
View file

@ -42,7 +42,7 @@ combineAnnotations = go
TypeAnnotation name tipe ->
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
let def' = E.Definition pat expr' (Just tipe)
(:) (D.Definition def') <$> go rest

2
compiler/Transform/Definition.hs
View file

@ -16,7 +16,7 @@ combineAnnotations = go
go defs =
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
let def = Definition pat expr' (Just tipe)
(:) def <$> go rest

28
compiler/Transform/Expression.hs
View file

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

37
compiler/Transform/SafeNames.hs
View file

@ -1,43 +1,44 @@
{-# OPTIONS_GHC -Wall #-}
module Transform.SafeNames (metadataModule) where
import Control.Arrow (first, (***))
import Data.List (intercalate)
import Control.Arrow (first, (***))
import qualified Data.List as List
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 qualified SourceSyntax.Helpers as SHelp
import SourceSyntax.Location
import SourceSyntax.Module
import SourceSyntax.Pattern
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as Variable
var :: String -> String
var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots
var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
where
deprime = map (\c -> if c == '\'' then '$' else c)
dereserve x = case Set.member x PHelp.jsReserveds of
False -> x
True -> "$" ++ x
pattern :: Pattern -> Pattern
pattern :: P.Pattern -> P.Pattern
pattern pat =
case pat of
PVar x -> PVar (var x)
PLiteral _ -> pat
PRecord fs -> PRecord (map var fs)
PAnything -> pat
PAlias x p -> PAlias (var x) (pattern p)
PData name ps -> PData name (map pattern ps)
P.Var x -> P.Var (var x)
P.Literal _ -> pat
P.Record fs -> P.Record (map var fs)
P.Anything -> pat
P.Alias x p -> P.Alias (var x) (pattern p)
P.Data name ps -> P.Data name (map pattern ps)
expression :: LExpr -> LExpr
expression (L loc expr) =
-- TODO: should be "normal expression" -> "expression for JS generation"
expression :: Expr -> Expr
expression (A ann expr) =
let f = expression in
L loc $
A ann $
case expr of
Literal _ -> expr
Var x -> Var (var x)
Var (Variable.Raw x) -> rawVar (var x)
Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es)
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.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.Set as Set
import qualified Data.Map as Map
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 pattern =
case pattern of
P.PVar _ -> []
P.PAlias _ p -> ctors p
P.PData ctor ps -> ctor : concatMap ctors ps
P.PRecord _ -> []
P.PAnything -> []
P.PLiteral _ -> []
P.Var _ -> []
P.Alias _ p -> ctors p
P.Data ctor ps -> ctor : concatMap ctors ps
P.Record _ -> []
P.Anything -> []
P.Literal _ -> []
free :: String -> State (Set.Set String) ()
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 boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
sortDefs :: LExpr -> LExpr
sortDefs :: Expr -> Expr
sortDefs expr = evalState (reorder expr) Set.empty
reorder :: LExpr -> State (Set.Set String) LExpr
reorder (L s expr) =
L s <$>
reorder :: Expr -> State (Set.Set String) Expr
reorder (A ann expr) =
A ann <$>
case expr of
-- Be careful adding and restricting freeVars
Var x -> free x >> return expr
Var (V.Raw x) -> free x >> return expr
Lambda p e ->
uncurry Lambda <$> bindingReorder (p,e)
@ -103,11 +104,11 @@ reorder (L s expr) =
bound (P.boundVars 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'
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) =
do expr' <- reorder expr
bound (P.boundVars pattern)

16
compiler/Transform/Substitute.hs
View file

@ -2,14 +2,16 @@
module Transform.Substitute (subst) where
import Control.Arrow (second, (***))
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Pattern as Pattern
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 =
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
Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es)
@ -28,7 +30,7 @@ subst old new expr =
anyShadow =
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
Data name es -> Data name (map f es)
Access e x -> Access (f e) x
@ -39,4 +41,4 @@ subst old new expr =
Literal _ -> expr
Markdown uid md es -> Markdown uid md (map f es)
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 #-}
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.Location as L
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T
toExpr :: [Declaration] -> [E.Def]
toExpr :: [D.Declaration] -> [E.Def]
toExpr = concatMap toDefs
toDefs :: Declaration -> [E.Def]
toDefs :: D.Declaration -> [E.Def]
toDefs decl =
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
toDefs' (ctor, tipes) =
let vars = take (length tipes) arguments
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) ]
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) ]
where
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
efields = zip (map fst fields) (map var vars)
record = case ext of
Nothing -> L.none $ E.Record efields
Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
Nothing -> A.none $ E.Record 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,
-- but they do not require any basic constraints.
TypeAlias _ _ _ -> []
D.TypeAlias _ _ _ -> []
Port port ->
D.Port port ->
case port of
Out name expr@(L.L s _) tipe ->
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
In name tipe ->
[ definition name (L.none $ E.PortIn name tipe) tipe ]
D.Out name expr@(A.A s _) tipe ->
[ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
D.In name tipe ->
[ definition name (A.none $ E.PortIn name tipe) tipe ]
-- no constraints are needed for fixity declarations
Fixity _ _ _ -> []
D.Fixity _ _ _ -> []
arguments :: [String]
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
buildFunction :: E.LExpr -> [String] -> E.LExpr
buildFunction body@(L.L s _) vars =
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
buildFunction :: E.Expr -> [String] -> E.Expr
buildFunction body@(A.A s _) 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 name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
definition :: String -> E.Expr -> T.Type -> E.Def
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 #-}
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 qualified Control.Monad as Monad
import Control.Monad.Error
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP
import SourceSyntax.Location as Loc
import SourceSyntax.Pattern (Pattern(PVar), boundVars)
import SourceSyntax.Annotation as Ann
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.Fragment
import qualified Type.Environment as Env
import qualified Type.Constrain.Literal as Literal
import qualified Type.Constrain.Pattern as Pattern
constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (L span expr) tipe =
constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (A region expr) tipe =
let list t = Env.get env Env.types "_List" <| t
and = L span . CAnd
true = L span CTrue
t1 === t2 = L span (CEqual t1 t2)
x <? t = L span (CInstance x t)
clet schemes c = L span (CLet schemes c)
and = A region . CAnd
true = A region CTrue
t1 === t2 = A region (CEqual t1 t2)
x <? t = A region (CInstance x t)
clet schemes c = A region (CLet schemes c)
in
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)
| otherwise -> return (name <? tipe)
Var (V.Raw name)
| name == saveEnvName -> return (A region CSaveEnv)
| otherwise -> return (name <? tipe)
Range lo hi ->
exists $ \x -> do
@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
Lambda p e ->
exists $ \t1 ->
exists $ \t2 -> do
fragment <- try span $ Pattern.constrain env p t1
fragment <- try region $ Pattern.constrain env p t1
c2 <- constrain env e t2
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
(typeConstraint fragment /\ c2 ))
@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
exists $ \t -> do
ce <- constrain env exp t
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
and . (:) ce <$> mapM branch branches
@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
Modify e fields ->
exists $ \t -> do
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)
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
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
Record fields ->
do vars <- forM fields $ \_ -> liftIO (var Flexible)
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)
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.
-- Currently, qs is always [].
case (pattern, maybeTipe) of
(PVar name, Just tipe) -> do
(P.Var name, Just tipe) -> do
flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
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 }
(vars, typ) <- Env.instantiateType env tipe Map.empty
let scheme = Scheme { rigidQuantifiers = [],
flexibleQuantifiers = flexiVars ++ vars,
constraint = Loc.noneNoDocs CTrue,
constraint = Ann.noneNoDocs CTrue,
header = Map.singleton name typ }
c <- constrain env' expr typ
return ( scheme : schemes
@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
, c2
, fl rigidVars c /\ c1 )
(PVar name, Nothing) -> do
(P.Var name, Nothing) -> do
v <- liftIO $ var Flexible
let tipe = VarN v
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)
expandPattern :: Def -> [Def]
expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
case pattern of
PVar _ -> [def]
_ -> Definition (PVar x) lexpr maybeType : map toDef vars
P.Var _ -> [def]
_ -> Definition (P.Var x) lexpr maybeType : map toDef vars
where
vars = Set.toList $ boundVars pattern
vars = P.boundVarList pattern
x = "$" ++ concat vars
mkVar = L s . Var
toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
mkVar = A r . rawVar
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 span computation = do
try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
try region computation = do
result <- liftIO $ runErrorT computation
case result of
Left err -> throwError [err span]
Left err -> throwError [err region]
Right value -> return value

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

@ -1,14 +1,15 @@
{-# OPTIONS_GHC -W #-}
module Type.Constrain.Literal where
import SourceSyntax.Annotation
import SourceSyntax.Literal
import SourceSyntax.Location
import Type.Type
import Type.Environment as Env
constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
constrain env span literal tipe =
constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
constrain env region literal tipe =
do tipe' <- litType
return . L span $ CEqual tipe tipe'
return . A region $ CEqual tipe tipe'
where
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 #-}
module Type.Constrain.Pattern where
@ -8,31 +9,29 @@ import Control.Monad.Error
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP
import SourceSyntax.Pattern
import SourceSyntax.Location
import SourceSyntax.PrettyPrint
import Text.PrettyPrint (render)
import qualified SourceSyntax.Location as Loc
import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint (pretty)
import Type.Type
import Type.Fragment
import Type.Environment as Env
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 =
let span = Loc.NoSpan (render $ pretty pattern)
t1 === t2 = Loc.L span (CEqual t1 t2)
x <? t = Loc.L span (CInstance x t)
let region = A.None (pretty pattern)
t1 === t2 = A.A region (CEqual t1 t2)
x <? t = A.A region (CInstance x t)
in
case pattern of
PAnything -> return emptyFragment
P.Anything -> return emptyFragment
PLiteral lit -> do
c <- liftIO $ Literal.constrain env span lit tipe
P.Literal lit -> do
c <- liftIO $ Literal.constrain env region lit tipe
return $ emptyFragment { typeConstraint = c }
PVar name -> do
P.Var name -> do
v <- liftIO $ var Flexible
return $ Fragment {
typeEnv = Map.singleton name (VarN v),
@ -40,14 +39,14 @@ constrain env pattern tipe =
typeConstraint = VarN v === tipe
}
PAlias name p -> do
P.Alias name p -> do
fragment <- constrain env p tipe
return $ fragment {
typeEnv = Map.insert name tipe (typeEnv fragment),
typeConstraint = name <? tipe /\ typeConstraint fragment
}
PData name patterns -> do
P.Data name patterns -> do
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
let msg = concat [ "Constructor '", name, "' expects ", show kind
, " argument", if kind == 1 then "" else "s"
@ -63,7 +62,7 @@ constrain env pattern tipe =
vars = cvars ++ vars fragment
}
PRecord fields -> do
P.Record fields -> do
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
let tenv = Map.fromList (map (second VarN) pairs)
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@ -73,8 +72,8 @@ constrain env pattern tipe =
typeConstraint = c
}
instance Error (SrcSpan -> PP.Doc) where
instance Error (A.Region -> PP.Doc) where
noMsg _ = PP.empty
strMsg str 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 #-}
{-| 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
-- 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.Monad.State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Traversable as Traverse
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.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 ]
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
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 =
case Map.lookup "main" env of
Nothing -> Right env
@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
acceptable = [ "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)."
, 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 " " ]
data Direction = In | Out
portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
portTypes rules expr =
const () <$> Expr.checkPorts (check In) (check Out) expr
where
check = isValid True False False
isValid isTopLevel seenFunc seenSignal direction name tipe =
case tipe of
T.Data ctor ts
ST.Data ctor ts
| isJs ctor || isElm ctor -> mapM_ valid ts
| ctor == "Signal.Signal" -> handleSignal ts
| 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
In -> err "functions"
Out | seenFunc -> err "higher-order functions"
| seenSignal -> err "signals that contain functions"
| otherwise ->
forM_ (T.collectLambdas tipe)
forM_ (ST.collectLambdas tipe)
(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
where
@ -100,7 +103,7 @@ portTypes rules expr =
[ txt [ "Type Error: the value ", dir "coming in" "sent out"
, " through port '", name, "' is invalid." ]
, 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"
, " ports include JavaScript values and" ]
, 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)." ]
]
occurs :: (String, Variable) -> StateT TS.SolverState IO ()
occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
occurs (name, variable) =
do vars <- liftIO $ infiniteVars [] variable
case vars of
[] -> return ()
var:_ -> do
desc <- liftIO $ UF.descriptor var
case structure desc of
case TT.structure desc of
Nothing ->
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
Just _ ->
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
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
msg = "Infinite types are not allowed"
fallback _ = return $ P.text msg
infiniteVars :: [Variable] -> Variable -> IO [Variable]
infiniteVars seen var =
infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
infiniteVars seen var =
let go = infiniteVars (var:seen) in
if var `elem` seen
then return [var]
else do
desc <- UF.descriptor var
case structure desc of
case TT.structure desc of
Nothing -> return []
Just struct ->
case struct of
App1 a b -> (++) <$> go a <*> go b
Fun1 a b -> (++) <$> go a <*> go b
Var1 a -> go a
EmptyRecord1 -> return []
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
TT.App1 a b -> (++) <$> go a <*> go b
TT.Fun1 a b -> (++) <$> go a <*> go b
TT.Var1 a -> go a
TT.EmptyRecord1 -> return []
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 SourceSyntax.Pattern
import SourceSyntax.Location (noneNoDocs)
import SourceSyntax.Annotation (noneNoDocs)
data Fragment = Fragment {
typeEnv :: Map.Map String Type,
vars :: [Variable],
typeConstraint :: TypeConstraint
} deriving Show
data Fragment = Fragment
{ typeEnv :: Map.Map String Type
, vars :: [Variable]
, typeConstraint :: TypeConstraint
} deriving Show
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
joinFragment f1 f2 = Fragment {
typeEnv = Map.union (typeEnv f1) (typeEnv f2),
vars = vars f1 ++ vars f2,
typeConstraint = typeConstraint f1 /\ typeConstraint f2
}
joinFragment f1 f2 = Fragment
{ typeEnv = Map.union (typeEnv f1) (typeEnv f2)
, vars = vars f1 ++ vars f2
, typeConstraint = typeConstraint f1 /\ typeConstraint f2
}
joinFragments = List.foldl' (flip joinFragment) emptyFragment
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 SourceSyntax.Module as Module
import SourceSyntax.Location (noneNoDocs)
import SourceSyntax.Annotation (noneNoDocs)
import SourceSyntax.Type (Type)
import Text.PrettyPrint
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.State
import qualified Data.UnionFind.IO as UF
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Traversable as Traversable
import qualified Data.List as List
import qualified Data.UnionFind.IO as UF
import Type.Type
import Type.Unify
import qualified Type.ExtraChecks as Check
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.
@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
solve :: TypeConstraint -> StateT TS.SolverState IO ()
solve (L span constraint) =
solve (A.A region constraint) =
case constraint of
CTrue -> return ()
@ -105,11 +105,11 @@ solve (L span constraint) =
CEqual term1 term2 -> do
t1 <- TS.flatten term1
t2 <- TS.flatten term2
unify span t1 t2
unify region t1 t2
CAnd cs -> mapM_ solve cs
CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
oldEnv <- TS.getEnv
mapM TS.introduce fqs
solve constraint'
@ -117,7 +117,7 @@ solve (L span constraint) =
CLet schemes constraint' -> do
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
solve constraint'
mapM Check.occurs $ Map.toList headers
@ -134,10 +134,10 @@ solve (L span constraint) =
error ("Could not find '" ++ name ++ "' when solving type constraints.")
t <- TS.flatten term
unify span freshCopy t
unify region freshCopy t
solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
solveScheme span scheme =
solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
solveScheme region scheme =
case scheme of
Scheme [] [] constraint header -> do
solve constraint
@ -154,39 +154,39 @@ solveScheme span scheme =
header' <- Traversable.traverse TS.flatten header
solve constraint
allDistinct span rigidQuantifiers
allDistinct region rigidQuantifiers
youngPool <- TS.getPool
TS.switchToPool oldPool
generalize youngPool
mapM (isGeneric span) rigidQuantifiers
mapM (isGeneric region) rigidQuantifiers
return header'
-- 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
-- a more complex term.
allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
allDistinct span vars = do
allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
allDistinct region vars = do
seen <- TS.uniqueMark
let check var = do
desc <- liftIO $ UF.descriptor var
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."
Nothing -> do
if mark desc == seen
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 ()
liftIO $ UF.setDescriptor var (desc { mark = seen })
mapM_ check vars
-- Check that a variable has rank == noRank, meaning that it can be generalized.
isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
isGeneric span var = do
isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
isGeneric region var = do
desc <- liftIO $ UF.descriptor var
if rank desc == noRank
then return ()
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 #-}
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.Monad.State
import qualified Data.Map as Map
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.Location
import Text.PrettyPrint as P
import qualified Type.Alias as Alias
import Type.Type
-- Pool
-- Holds a bunch of variables
@ -46,7 +47,7 @@ initialState = SS {
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv 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 }
where
makeError rules = do
@ -54,24 +55,15 @@ addError span hint t1 t2 =
t1' <- prettiest <$> toSrcType t1
t2' <- prettiest <$> toSrcType t2
return . P.vcat $
[ P.text $ "Type error" ++ location ++ ":"
[ P.text "Type error" <+> pretty region <> P.colon
, 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 " 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)
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.Error
import Data.Traversable (traverse)
import SourceSyntax.Location
import SourceSyntax.Annotation
import SourceSyntax.Helpers (isTuple)
import qualified SourceSyntax.Type as Src
@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
infixl 8 /\
(/\) :: 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
(CTrue, _) -> b
(_, CTrue) -> a
@ -128,11 +128,13 @@ structuredVar structure = UF.fresh $ Descriptor {
-- ex qs constraint == exists qs. constraint
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 :: [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 f = do
@ -148,8 +150,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
instance PrettyType a => PrettyType (Located a) where
pretty when (L _ e) = pretty when e
instance PrettyType t => PrettyType (Annotated a t) where
pretty when (A _ e) = pretty when e
instance PrettyType a => PrettyType (Term1 a) where
@ -212,12 +214,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
CAnd 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 ]
where
mergeExists vs (L _ c) =
mergeExists vs (A _ c) =
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)
(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
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' ]
where
prty = pretty Never
@ -297,8 +299,8 @@ class Crawl t where
-> t
-> StateT CrawlState IO t
instance Crawl a => Crawl (Located a) where
crawl nextState (L s e) = L s <$> crawl nextState e
instance Crawl e => Crawl (Annotated a e) where
crawl nextState (A ann e) = A ann <$> crawl nextState e
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
crawl nextState constraint =

30
compiler/Type/Unify.hs
View file

@ -1,27 +1,27 @@
{-# OPTIONS_GHC -W #-}
module Type.Unify (unify) where
import Type.Type
import qualified Data.UnionFind.IO as UF
import Control.Monad.State
import qualified Data.Map as Map
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 Control.Monad.State
import SourceSyntax.Location
import Type.Type
import Type.PrettyPrint
import Text.PrettyPrint (render)
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
unify span variable1 variable2 = do
unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
unify region variable1 variable2 = do
equivalent <- liftIO $ UF.equivalent variable1 variable2
if equivalent then return ()
else actuallyUnify span variable1 variable2
else actuallyUnify region variable1 variable2
actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
actuallyUnify span variable1 variable2 = do
actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
actuallyUnify region variable1 variable2 = do
desc1 <- liftIO $ UF.descriptor variable1
desc2 <- liftIO $ UF.descriptor variable2
let unify' = unify span
let unify' = unify region
name' :: Maybe String
name' = case (name desc1, name desc2) of
@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
unifyNumber svar name
| 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."
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."
unifyComparable var name
@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
List _ -> flexAndUnify varSuper
_ -> comparableError Nothing
rigidError variable = TS.addError span (Just hint) variable1 variable2
rigidError variable = TS.addError region (Just hint) variable1 variable2
where
var = "'" ++ render (pretty Never variable) ++ "'"
hint = "Cannot unify rigid type variable " ++ var ++
@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
(Rigid, _, _, _) -> rigidError variable1
(_, Rigid, _, _) -> rigidError variable2
_ -> TS.addError span Nothing variable1 variable2
_ -> TS.addError region Nothing variable1 variable2
case (structure desc1, structure desc2) of
(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 _ = xs
_ -> TS.addError span Nothing variable1 variable2
_ -> TS.addError region Nothing variable1 variable2