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

Simplify SourceSyntax.Type AST, making record extension more restrictive as discussed with @maxsnew

Browse source
This commit is contained in:
Evan Czaplicki 2014-01-13 09:23:23 +01:00
parent 9dda928ac4
commit 2a0a0e6e3c
10 changed files with 54 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
compiler/Docs.hs
View file

@ -7,7 +7,7 @@ import System.FilePath
import System.Exit
import System.IO
import Control.Applicative ((<$>), (<*>))
import Control.Applicative ((<$>))
import Data.Aeson
import Data.Aeson.Encode.Pretty
import qualified Data.List as List
@ -154,11 +154,10 @@ instance ToJSON Type where
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
Var x -> toJSON x
Data name ts -> toJSON (toJSON name : map toJSON ts)
EmptyRecord -> object []
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
where fields' = case ext of
EmptyRecord -> fields
_ -> ("_",ext) : fields
Nothing -> fields
Just x -> ("_", Var x) : fields
ctorToJson tipe (ctor, tipes) =
object [ "name" .= ctor

14
compiler/Parse/Type.hs
View file

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
module Parse.Type where
import Control.Applicative ((<$>),(<*>))
import Control.Applicative ((<$>),(<*>),(<*))
import Data.List (intercalate)
import Text.Parsec
@ -23,19 +23,19 @@ tuple = do ts <- parens (commaSep expr)
record :: IParser T.Type
record =
do char '{' ; whitespace
(ext,fs) <- extended <|> normal
rcrd <- extended <|> normal
dumbWhitespace ; char '}'
return (T.Record fs ext)
return rcrd
where
normal = (,) T.EmptyRecord <$> commaSep fields
normal = flip T.Record Nothing <$> commaSep field
-- extended record types require at least one field
extended = do
ext <- try (const <$> tvar <*> (whitespace >> string "|"))
ext <- try (lowVar <* (whitespace >> string "|"))
whitespace
(,) ext <$> commaSep1 fields
flip T.Record (Just ext) <$> commaSep1 field
fields = do
field = do
lbl <- rLabel
whitespace >> hasType >> whitespace
(,) lbl <$> expr

29
compiler/SourceSyntax/Type.hs
View file

@ -11,8 +11,7 @@ import Text.PrettyPrint as P
data Type = Lambda Type Type
| Var String
| Data String [Type]
| EmptyRecord
| Record [(String,Type)] Type
| Record [(String,Type)] (Maybe String)
deriving (Eq, Show)
fieldMap :: [(String,a)] -> Map.Map String [a]
@ -20,7 +19,7 @@ fieldMap fields =
foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
recordOf :: [(String,Type)] -> Type
recordOf fields = Record fields EmptyRecord
recordOf fields = Record fields Nothing
listOf :: Type -> Type
listOf t = Data "_List" [t]
@ -39,12 +38,11 @@ instance Pretty Type where
Data name tipes
| Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
| otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
EmptyRecord -> P.braces P.empty
Record _ _ -> P.braces $ case ext of
EmptyRecord -> prettyFields
_ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields
Record fields ext ->
P.braces $ case ext of
Nothing -> prettyFields
Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields
where
(fields, ext) = collectRecords tipe
prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
prettyFields = commaSep . map prettyField $ fields
@ -55,14 +53,6 @@ collectLambdas tipe =
Lambda arg body -> pretty arg : collectLambdas body
_ -> [pretty tipe]
collectRecords :: Type -> ([(String,Type)], Type)
collectRecords = go []
where
go fields tipe =
case tipe of
Record fs ext -> go (fs ++ fields) ext
_ -> (fields, tipe)
prettyParens :: Type -> Doc
prettyParens tipe = parensIf needed (pretty tipe)
where
@ -83,10 +73,8 @@ instance Binary Type where
putWord8 1 >> put x
Data ctor tipes ->
putWord8 2 >> put ctor >> put tipes
EmptyRecord ->
putWord8 3
Record fs ext ->
putWord8 4 >> put fs >> put ext
putWord8 3 >> put fs >> put ext
get = do
n <- getWord8
@ -94,6 +82,5 @@ instance Binary Type where
0 -> Lambda <$> get <*> get
1 -> Var <$> get
2 -> Data <$> get <*> get
3 -> return EmptyRecord
4 -> Record <$> get <*> get
3 -> Record <$> get <*> get
_ -> error "Error reading a valid type from serialized string"

3
compiler/Transform/Canonicalize.hs
View file

@ -47,8 +47,7 @@ renameType renamer tipe =
Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
Type.Var _ -> return tipe
Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
Type.EmptyRecord -> return tipe
Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
where rnm' (f,t) = (,) f <$> rnm t
metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

7
compiler/Transform/Check.hs
View file

@ -102,8 +102,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
T.Var x -> Set.singleton x
T.Data _ ts -> Set.unions (map freeVars ts)
T.EmptyRecord -> Set.empty
T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
where ext' = maybe Set.empty Set.singleton ext
undeclared tvars tipes = Set.difference used declared
where
@ -147,8 +147,7 @@ infiniteTypeAliases decls =
T.Lambda a b -> infinite a || infinite b
T.Var _ -> False
T.Data name' ts -> name == name' || any infinite ts
T.EmptyRecord -> False
T.Record fields ext -> infinite ext || any (infinite . snd) fields
T.Record fields _ -> any (infinite . snd) fields
indented :: D.Declaration -> Doc
indented decl = P.text "\n " <> pretty decl <> P.text "\n"

28
compiler/Type/Alias.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
module Type.Alias (realias, rules, canonicalRealias, Rules) where
import Control.Applicative ((<$>),(<*>))
@ -30,10 +31,9 @@ localizer moduleImports = go
go tipe =
case tipe of
Var _ -> tipe
EmptyRecord -> tipe
Lambda t1 t2 -> Lambda (go t1) (go t2)
Data name ts -> Data (localize name) (map go ts)
Record fs ext -> Record (map (second go) fs) (go ext)
Record fs ext -> Record (map (second go) fs) ext
byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
Map.empty moduleImports
@ -83,10 +83,9 @@ canonicalRealias aliases tipe =
tipe' =
case tipe of
Var _ -> tipe
EmptyRecord -> tipe
Lambda t1 t2 -> Lambda (f t1) (f t2)
Data name ts -> Data name (map f ts)
Record fs ext -> Record (map (second f) fs) (f ext)
Record fs ext -> Record (map (second f) fs) ext
allEqual [] = True
allEqual (x:xs) = all (==x) xs
@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
Lambda t1 t2 -> numFields t1 + numFields t2
Var _ -> 0
Data _ ts -> sum (map numFields ts)
EmptyRecord -> 0
Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext
Record fields _ -> length fields + sum (map (numFields . snd) fields)
diff :: Type -> Type -> Maybe [(String,Type)]
diff general specific =
@ -113,11 +111,11 @@ diff general specific =
(Data gname gts, Data sname sts)
| gname == sname && length gts == length sts ->
concat <$> zipWithM diff gts sts
(EmptyRecord, EmptyRecord) -> Just []
(Record _ _, Record _ _) ->
let (gfs,gext) = collectRecords general
(sfs,sext) = collectRecords specific
gfields = collectFields gfs
(Record [] Nothing, Record [] Nothing) -> Just []
(Record _ _, Record [] Nothing) -> Nothing
(Record [] Nothing, Record _ _) -> Nothing
(Record gfs gext, Record sfs sext) ->
let gfields = collectFields gfs
sfields = collectFields sfs
overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
@ -126,10 +124,12 @@ diff general specific =
case isAligned of
False -> Nothing
True -> let remaining = Map.difference sfields gfields
sext' = if Map.null remaining then sext else
Record (flattenFields remaining) sext
sext' = case sext of
Just x | Map.null remaining -> Var x
_ -> Record (flattenFields remaining) sext
gext' = maybe (Record [] Nothing) Var gext
matchMap = Map.intersectionWith (zipWith diff) gfields sfields
in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))
in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))
(_,_) -> Nothing
collectFields fields =

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

@ -28,17 +28,15 @@ toDefs decl =
TypeAlias name _ tipe@(T.Record fields ext) _ ->
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
where
args = case ext of
T.EmptyRecord -> map snd fields
_ -> map snd fields ++ [ext]
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
var = L.none . E.Var
vars = take (length args) arguments
efields = zip (map fst fields) (map var vars)
record = case ext of
T.EmptyRecord -> L.none $ E.Record efields
_ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
Nothing -> L.none $ E.Record efields
Just _ -> foldl (\r (f,v) -> L.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.

10
compiler/Type/Environment.hs
View file

@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType
_ -> error $ "\nCould not find type constructor '" ++
name ++ "' while checking types."
Src.EmptyRecord -> return (TermN EmptyRecord1)
Src.Record fields ext ->
TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)
Src.Record fields ext -> do
fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
ext' <- case ext of
Nothing -> return $ TermN EmptyRecord1
Just x -> go (Src.Var x)
return $ TermN (Record1 fields' ext')

1
compiler/Type/ExtraChecks.hs
View file

@ -96,7 +96,6 @@ portTypes rules expr =
| otherwise -> throw $ err msg "Elm values"
T.Var _ -> throw $ err msg "type variables"
T.Lambda _ _ -> throw $ err msg "Elm functions"
T.EmptyRecord -> throw $ err msg "Elm records"
T.Record _ _ -> throw $ err msg "Elm records"
where
okay ctor = and [ List.isPrefixOf "JavaScript." ctor

14
compiler/Type/Type.hs
View file

@ -364,11 +364,15 @@ toSrcType variable = do
return (Src.Data name (ts ++ [b']))
Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
Var1 a -> toSrcType a
EmptyRecord1 -> return Src.EmptyRecord
Record1 fs ext -> do
fs' <- traverse (mapM toSrcType) fs
let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]
Src.Record fs'' <$> toSrcType ext
EmptyRecord1 -> return $ Src.Record [] Nothing
Record1 tfields extension -> do
fields' <- traverse (mapM toSrcType) tfields
let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
ext' <- toSrcType extension
return $ case ext' of
Src.Record fs ext -> Src.Record (fs ++ fields) ext
Src.Var x -> Src.Record fields (Just x)
_ -> error "Used toSrcType on a type that is not well-formed"
Nothing ->
case name desc of
Just x@(c:_) | Char.isLower c -> return (Src.Var x)