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

Begin getting the parser to match the new SourceSyntax modules.

Browse source
This commit is contained in:
evancz 2013-06-13 18:35:37 -07:00
parent bbb2b2a14f
commit 339ad77c46
12 changed files with 75 additions and 218 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

0
compiler/Model/Guid.hs → compiler/Guid.hs
View file

156
compiler/Model/Ast.hs
View file

@ -1,156 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Ast where
import Located
import Data.Char (isDigit, isSymbol)
import Data.List (intercalate)
import Types.Types
import qualified Text.Pandoc as Pandoc
import Data.Data
data Module = Module [String] Exports Imports [Statement]
deriving (Show)
type Exports = [String]
type Imports = [(String, ImportMethod)]
data ImportMethod = As String | Importing [String] | Hiding [String]
deriving (Eq, Ord, Show, Data, Typeable)
data Pattern = PData String [Pattern]
| PRecord [String]
| PAsVar String Pattern
| PVar String
| PAnything
deriving (Eq, Data, Typeable)
type CExpr = Located Expr
data Expr = IntNum Int
| FloatNum Float
| Chr Char
| Str String
| Boolean Bool
| Range CExpr CExpr
| Access CExpr String
| Remove CExpr String
| Insert CExpr String CExpr
| Modify CExpr [(String,CExpr)]
| Record [(String,[String],CExpr)]
| Binop String CExpr CExpr
| Lambda String CExpr
| App CExpr CExpr
| MultiIf [(CExpr,CExpr)]
| Let [Def] CExpr
| Var String
| Case CExpr [(Pattern,CExpr)]
| Data String [CExpr]
| Markdown Pandoc.Pandoc
deriving (Eq, Data, Typeable)
data Def = FnDef String [String] CExpr
| OpDef String String String CExpr
| TypeAnnotation String Type
deriving (Eq, Data, Typeable)
data Statement = Definition Def
| Datatype String [X] [(String,[Type])]
| TypeAlias String [X] Type
| ImportEvent String CExpr String Type
| ExportEvent String String Type
deriving (Eq, Show, Data, Typeable)
cons h t = epos h t (Data "Cons" [h,t])
nil = L (Just "[]") NoSpan (Data "Nil" [])
list = foldr cons nil
tuple es = Data ("Tuple" ++ show (length es)) es
delist (L _ _ (Data "Cons" [h,t])) = h : delist t
delist _ = []
pcons h t = PData "Cons" [h,t]
pnil = PData "Nil" []
plist = foldr pcons pnil
ptuple es = PData ("Tuple" ++ show (length es)) es
brkt s = "{ " ++ s ++ " }"
parensIf b s = if b then parens s else s
isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
instance Show Pattern where
show p =
case p of
PRecord fs -> brkt (intercalate ", " fs)
PVar x -> x
PAsVar x p -> show p ++ " as " ++ x
PAnything -> "_"
PData "Cons" [hd@(PData "Cons" _),tl] ->
parens (show hd) ++ " :: " ++ show tl
PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
PData "Nil" [] -> "[]"
PData name ps ->
if take 5 name == "Tuple" && all isDigit (drop 5 name) then
parens . intercalate ", " $ map show ps
else parensIf (not (null ps)) $ unwords (name : map show ps)
instance Show Expr where
show e =
let show' (L _ _ e) = parensIf (needsParens e) (show e) in
case e of
IntNum n -> show n
FloatNum n -> show n
Chr c -> show c
Str s -> show s
Boolean b -> show b
Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
Access e x -> show' e ++ "." ++ x
Remove e x -> brkt (show e ++ " - " ++ x)
Insert (L _ _ (Remove e y)) x v ->
brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
where field (x,e) = x ++ " <- " ++ show e
Record r -> brkt (intercalate ", " (map fields r))
where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in
concat [ "\\", intercalate " " xs, " -> ", show e' ]
App e1 e2 -> show' e1 ++ " " ++ show' e2
MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
where iff (b,e) = show b ++ " -> " ++ show e
sep = concatMap ("\n | " ++)
Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
Var (c:cs) -> if isOp c then parens (c:cs) else c:cs
Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
Data name es
| name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
delist (notLocated $ Data "Cons" es)
| name == "Nil" -> "[]"
| otherwise -> name ++ " " ++ intercalate " " (map show' es)
Markdown _ -> "[markdown| ... |]"
instance Show Def where
show e =
case e of
FnDef v [] e -> v ++ " = " ++ show e
FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
TypeAnnotation n t -> n ++ " : " ++ show t
getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
where (xs,e') = getLambdas e
getLambdas e = ([],e)
needsParens e =
case e of
Binop _ _ _ -> True
Lambda _ _ -> True
App _ _ -> True
MultiIf _ -> True
Let _ _ -> True
Case _ _ -> True
Data name (x:xs) -> name /= "Cons"
_ -> False

32
compiler/Parse/Binops.hs
View file

@ -1,18 +1,14 @@
module Parse.Binops (binops, infixStmt, OpTable) where
import Ast
import Control.Monad (liftM,guard)
import Control.Monad.Error
import Data.List (foldl',splitAt,elemIndices
,group,groupBy,sortBy,find,intercalate)
import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Located (epos)
import SourceSyntax.Location (merge)
import SourceSyntax.Expression (LExpr, Expr(Binop))
import SourceSyntax.Declaration (Assoc(..))
import Text.Parsec
import Parse.Library
data Assoc = L | N | R deriving (Eq,Show)
import Parse.Helpers
type OpTable = [(Int, Assoc, String)]
@ -39,10 +35,10 @@ opAssoc :: OpTable -> String -> Assoc
opAssoc table op = Map.findWithDefault R op dict
where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool
hasLevel :: OpTable -> Int -> (String,LExpr) -> Bool
hasLevel table n (op,_) = opLevel table op == n
binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr
binops :: OpTable -> IParser LExpr -> IParser String -> IParser LExpr
binops table term anyOp =
do e <- term
split (table ++ preludeTable) 0 e =<< many nextOp
@ -52,7 +48,7 @@ binops table term anyOp =
whitespace ; e <- term
return (op,e)
split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
split :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> IParser LExpr
split _ _ e [] = return e
split table n e eops = do
assoc <- getAssoc table n eops
@ -61,25 +57,25 @@ split table n e eops = do
case assoc of R -> joinR es ops
_ -> joinL es ops
splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
splitLevel :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> [IParser LExpr]
splitLevel table n e eops =
case break (hasLevel table n) eops of
(lops, (op,e'):rops) ->
split table (n+1) e lops : splitLevel table n e' rops
(lops, []) -> [ split table (n+1) e lops ]
joinL :: [CExpr] -> [String] -> IParser CExpr
joinL :: [LExpr] -> [String] -> IParser LExpr
joinL [e] [] = return e
joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops
joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
joinR :: [CExpr] -> [String] -> IParser CExpr
joinR :: [LExpr] -> [String] -> IParser LExpr
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
return (epos a e (Binop op a e))
return (merge a e (Binop op a e))
joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc
getAssoc :: OpTable -> Int -> [(String,LExpr)] -> IParser Assoc
getAssoc table n eops
| all (==L) assocs = return L
| all (==R) assocs = return R

17
compiler/Parse/Expr.hs
View file

@ -1,7 +1,5 @@
module Parse.Expr (def,term) where
import Ast
import Located
import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Data.Char (isSymbol, isDigit)
@ -15,6 +13,9 @@ import Parse.Patterns
import Parse.Binops
import Parse.Types
import Ast
import Located
import Guid
import Types.Types (Type (VarT), Scheme (Forall))
@ -70,7 +71,7 @@ listTerm =
return e
])
parensTerm :: IParser CExpr
parensTerm :: IParser LExpr
parensTerm = parens $ choice
[ do start <- getPosition
op <- try anyOp
@ -93,7 +94,7 @@ parensTerm = parens $ choice
_ -> pos start end (tuple es)
]
recordTerm :: IParser CExpr
recordTerm :: IParser LExpr
recordTerm = brackets $ choice [ misc, addLocation record ]
where field = do
fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
@ -125,14 +126,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
Nothing -> try (insert record) <|> try (modify record)
term :: IParser CExpr
term :: IParser LExpr
term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
<?> "basic term (4, x, 'c', etc.)"
-------- Applications --------
appExpr :: IParser CExpr
appExpr :: IParser LExpr
appExpr = do
tlist <- spaceSep1 term
return $ case tlist of
@ -141,7 +142,7 @@ appExpr = do
-------- Normal Expressions --------
binaryExpr :: IParser CExpr
binaryExpr :: IParser LExpr
binaryExpr = binops [] appExpr anyOp
ifExpr :: IParser Expr
@ -159,7 +160,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
b <- expr ; whitespace ; string "->" ; whitespace
(,) b <$> expr
lambdaExpr :: IParser CExpr
lambdaExpr :: IParser LExpr
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
whitespace
pats <- spaceSep1 patternTerm

18
compiler/Parse/Library.hs → compiler/Parse/Helpers.hs
View file

@ -1,13 +1,13 @@
module Parse.Helpers where
module Parse.Library where
import Ast
import Located
import Control.Applicative ((<$>),(<*>))
import Control.Monad
import Control.Monad.State
import Data.Char (isUpper)
import Rename (deprime)
import SourceSyntax.Helpers (isOp)
import SourceSyntax.Location as Location
import SourceSyntax.Expression
import SourceSyntax.Rename (deprime)
import Text.Parsec hiding (newline,spaces,State)
import Text.Parsec.Indent
@ -124,14 +124,14 @@ parens = surround '(' ')' "paren"
brackets :: IParser a -> IParser a
brackets = surround '{' '}' "bracket"
addLocation :: IParser Expr -> IParser CExpr
addLocation :: IParser Expr -> IParser LExpr
addLocation expr = do
start <- getPosition
e <- expr
end <- getPosition
return (pos start end e)
return (Location.at start end e)
accessible :: IParser CExpr -> IParser CExpr
accessible :: IParser LExpr -> IParser LExpr
accessible expr = do
start <- getPosition
ce@(L s t e) <- expr
@ -143,7 +143,7 @@ accessible expr = do
Just _ -> accessible $ do
v <- var <?> "field access (e.g. List.map)"
end <- getPosition
return (pos start end (f v))
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)

2
compiler/Parse/Patterns.hs
View file

@ -1,5 +1,5 @@
module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
module Parse.Pattern (patternTerm, patternExpr, makeLambda, flattenPatterns) where
import Ast
import Located

15
compiler/Parse/Types.hs
View file

@ -1,6 +1,5 @@
module Parse.Types where
import Ast
import Control.Applicative ((<$>),(<*>))
import Control.Monad (liftM,mapM)
import Data.Char (isUpper,isLower)
@ -9,8 +8,10 @@ import Data.List (lookup,intercalate)
import Text.Parsec
import Text.Parsec.Indent
import Located
import Parse.Library
import SourceSyntax.Location as Located
import SourceSyntax.Expression
import SourceSyntax.Declaration
import Parse.Helpers
import Types.Types hiding (parens,string)
import Guid
@ -69,7 +70,7 @@ typeConstructor :: IParser (String, [ParseType])
typeConstructor = (,) <$> (capVar <?> "another type constructor")
<*> spacePrefix (typeSimple <|> typeUnambiguous)
typeAlias :: IParser [Statement]
typeAlias :: IParser [Declaration]
typeAlias = do
start <- getPosition
reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
@ -91,13 +92,13 @@ typeAlias = do
toConstructor start end alias Nothing kvs =
Definition (FnDef alias args (loc (Record rec)))
where
loc = pos start end
loc = Located.at start end
args = map fst kvs
rec = map (\a -> (a, [], loc (Var a))) args
toConstructor start end alias (Just _) kvs =
Definition (FnDef alias (args++["_ext_"]) (loc rec))
where
loc = pos start end
loc = Located.at start end
args = map fst kvs
rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
insert e (k,v) = Insert (loc e) k v
@ -107,7 +108,7 @@ typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
where start = do v <- lowVar <|> parens symOp
whitespace ; hasType ; whitespace ; return v
datatype :: IParser Statement
datatype :: IParser Declaration
datatype = do
reserved "data" <?> "datatype definition (data T = A | B | ...)"
forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

5
compiler/SourceSyntax/Declaration.hs
View file

@ -11,5 +11,8 @@ data Declaration
| TypeAlias String [X] Type
| ImportEvent String Expr.LExpr String Type
| ExportEvent String String Type
| Fixity Int String
| Fixity Assoc Int String
deriving (Eq, Show, Data, Typeable)
data Assoc = L | N | R
deriving (Eq, Show, Data, Typeable)

19
compiler/Transform/Rename.hs → compiler/SourceSyntax/Rename.hs
View file

@ -1,13 +1,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rename (renameModule, derename, deprime) where
module SourceSyntax.Rename (renameModule, derename, deprime) where
import Ast
import Located
import Control.Arrow (first)
import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
import Control.Monad.State (evalState, State, get, put)
import Data.Char (isLower,isDigit)
import Guid
import SourceSyntax.Location
import SourceSyntax.Pattern
import SourceSyntax.Expression
import SourceSyntax.Declaration hiding (Assoc(..))
import SourceSyntax.Module
derename var
| isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
@ -33,7 +36,7 @@ instance Rename Def where
rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
instance Rename Statement where
instance Rename Declaration where
rename env stmt =
case stmt of
Definition def -> Definition `liftM` rename env def
@ -126,10 +129,10 @@ patternExtend pattern env =
case pattern of
PAnything -> return (PAnything, env)
PVar x -> first PVar `liftM` extend env x
PAsVar x p -> do
PAlias x p -> do
(x', env') <- extend env x
(p', env'') <- patternExtend p env'
return (PAsVar x' p', env'')
return (PAlias x' p', env'')
PData name ps ->
first (PData name . reverse) `liftM` foldM f ([], env) ps
where f (rps,env') p = do (rp,env'') <- patternExtend p env'
@ -137,7 +140,9 @@ patternExtend pattern env =
PRecord fs ->
return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
patternRename :: (String -> String)
-> (Pattern, LExpr)
-> GuidCounter (Pattern, LExpr)
patternRename env (p,e) = do
(rp,env') <- patternExtend p env
re <- rename env' e

21
compiler/Types/Solver.hs
View file

@ -14,6 +14,8 @@ import Types.Types
import Types.Substitutions
import Types.Alias (dealias)
import System.IO.Unsafe
isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
isSolved ss c = False
@ -21,12 +23,15 @@ isSolved ss c = False
type Aliases = Map.Map String ([X],Type)
crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)
crush aliases (Forall xs cs t) =
crush aliases forall@(Forall xs cs t) =
do subs <- solver aliases Map.empty cs
return $ do ss' <- subs
let ss = Map.toList ss'
cs' = filter (not . isSolved ss) (subst ss cs)
return $ Forall xs cs' (subst ss t)
f x = (unsafePerformIO $ do
print forall >> putStrLn "-------"
print x >> putStrLn "~~~~~~~") `seq` x
return . f $ Forall xs cs' (subst ss t)
schemeSubHelp txt span x s t1 rltn t2 = do
(t1',cs1) <- sub t1
@ -36,11 +41,10 @@ schemeSubHelp txt span x s t1 rltn t2 = do
| otherwise = do (st, cs) <- concretize s
return (subst [(x,st)] t, cs)
schemeSub aliases x s c =
do s' <- crush aliases s
case s' of
Right s'' -> Right `liftM` schemeSub' x s'' c
Left err -> return $ Left err
schemeSub x s' c =
case s' of
Right s'' -> Right `liftM` schemeSub' x s'' c
Left err -> return $ Left err
schemeSub' x s c@(L txt span constraint) =
case constraint of
@ -170,7 +174,8 @@ solver aliases subs (L txt span c : cs) =
x :<<: s
| any (occurs x) cs ->
do css <- mapM (schemeSub aliases x s) cs
do s' <- crush aliases s
css <- mapM (schemeSub x s') cs
case lefts css of
err : _ -> return $ Left err
[] -> solv (concat (rights css))

2
compiler/Types/Types.hs
View file

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Types.Types where
import Located
import SourceSyntax.Location
import Data.Char (isDigit)
import Data.List (intercalate,isPrefixOf)
import qualified Data.Set as Set

6
compiler/Types/Unify.hs
View file

@ -19,7 +19,9 @@ unify hints modul@(Module _ _ _ stmts) = run $ do
case result of
Left err -> return (Left err)
Right (schemes, constraints) ->
do subs <- Solver.solver (Alias.get stmts) Map.empty constraints
do subs <- unsafePerformIO (mapM print constraints) `seq`
Solver.solver (Alias.get stmts) Map.empty constraints
let ss = either (const []) Map.toList subs
unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq` return subs
-- unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq`
return subs