Simplify SourceSyntax.Type AST, making record extension more restrictive as discussed with @maxsnew
This commit is contained in:
parent
9dda928ac4
commit
2a0a0e6e3c
10 changed files with 54 additions and 67 deletions
|
@ -7,7 +7,7 @@ import System.FilePath
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
import Control.Applicative ((<$>))
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Aeson.Encode.Pretty
|
import Data.Aeson.Encode.Pretty
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
|
@ -154,11 +154,10 @@ instance ToJSON Type where
|
||||||
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
|
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
|
||||||
Var x -> toJSON x
|
Var x -> toJSON x
|
||||||
Data name ts -> toJSON (toJSON name : map toJSON ts)
|
Data name ts -> toJSON (toJSON name : map toJSON ts)
|
||||||
EmptyRecord -> object []
|
|
||||||
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
||||||
where fields' = case ext of
|
where fields' = case ext of
|
||||||
EmptyRecord -> fields
|
Nothing -> fields
|
||||||
_ -> ("_",ext) : fields
|
Just x -> ("_", Var x) : fields
|
||||||
|
|
||||||
ctorToJson tipe (ctor, tipes) =
|
ctorToJson tipe (ctor, tipes) =
|
||||||
object [ "name" .= ctor
|
object [ "name" .= ctor
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
|
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
|
||||||
module Parse.Type where
|
module Parse.Type where
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>),(<*))
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Text.Parsec
|
import Text.Parsec
|
||||||
|
|
||||||
|
@ -23,19 +23,19 @@ tuple = do ts <- parens (commaSep expr)
|
||||||
record :: IParser T.Type
|
record :: IParser T.Type
|
||||||
record =
|
record =
|
||||||
do char '{' ; whitespace
|
do char '{' ; whitespace
|
||||||
(ext,fs) <- extended <|> normal
|
rcrd <- extended <|> normal
|
||||||
dumbWhitespace ; char '}'
|
dumbWhitespace ; char '}'
|
||||||
return (T.Record fs ext)
|
return rcrd
|
||||||
where
|
where
|
||||||
normal = (,) T.EmptyRecord <$> commaSep fields
|
normal = flip T.Record Nothing <$> commaSep field
|
||||||
|
|
||||||
-- extended record types require at least one field
|
-- extended record types require at least one field
|
||||||
extended = do
|
extended = do
|
||||||
ext <- try (const <$> tvar <*> (whitespace >> string "|"))
|
ext <- try (lowVar <* (whitespace >> string "|"))
|
||||||
whitespace
|
whitespace
|
||||||
(,) ext <$> commaSep1 fields
|
flip T.Record (Just ext) <$> commaSep1 field
|
||||||
|
|
||||||
fields = do
|
field = do
|
||||||
lbl <- rLabel
|
lbl <- rLabel
|
||||||
whitespace >> hasType >> whitespace
|
whitespace >> hasType >> whitespace
|
||||||
(,) lbl <$> expr
|
(,) lbl <$> expr
|
||||||
|
|
|
@ -11,8 +11,7 @@ import Text.PrettyPrint as P
|
||||||
data Type = Lambda Type Type
|
data Type = Lambda Type Type
|
||||||
| Var String
|
| Var String
|
||||||
| Data String [Type]
|
| Data String [Type]
|
||||||
| EmptyRecord
|
| Record [(String,Type)] (Maybe String)
|
||||||
| Record [(String,Type)] Type
|
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
fieldMap :: [(String,a)] -> Map.Map String [a]
|
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
|
foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
|
||||||
|
|
||||||
recordOf :: [(String,Type)] -> Type
|
recordOf :: [(String,Type)] -> Type
|
||||||
recordOf fields = Record fields EmptyRecord
|
recordOf fields = Record fields Nothing
|
||||||
|
|
||||||
listOf :: Type -> Type
|
listOf :: Type -> Type
|
||||||
listOf t = Data "_List" [t]
|
listOf t = Data "_List" [t]
|
||||||
|
@ -39,12 +38,11 @@ instance Pretty Type where
|
||||||
Data name tipes
|
Data name tipes
|
||||||
| Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty 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)
|
| otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
|
||||||
EmptyRecord -> P.braces P.empty
|
Record fields ext ->
|
||||||
Record _ _ -> P.braces $ case ext of
|
P.braces $ case ext of
|
||||||
EmptyRecord -> prettyFields
|
Nothing -> prettyFields
|
||||||
_ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields
|
Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields
|
||||||
where
|
where
|
||||||
(fields, ext) = collectRecords tipe
|
|
||||||
prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
|
prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
|
||||||
prettyFields = commaSep . map prettyField $ fields
|
prettyFields = commaSep . map prettyField $ fields
|
||||||
|
|
||||||
|
@ -55,14 +53,6 @@ collectLambdas tipe =
|
||||||
Lambda arg body -> pretty arg : collectLambdas body
|
Lambda arg body -> pretty arg : collectLambdas body
|
||||||
_ -> [pretty tipe]
|
_ -> [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 :: Type -> Doc
|
||||||
prettyParens tipe = parensIf needed (pretty tipe)
|
prettyParens tipe = parensIf needed (pretty tipe)
|
||||||
where
|
where
|
||||||
|
@ -83,10 +73,8 @@ instance Binary Type where
|
||||||
putWord8 1 >> put x
|
putWord8 1 >> put x
|
||||||
Data ctor tipes ->
|
Data ctor tipes ->
|
||||||
putWord8 2 >> put ctor >> put tipes
|
putWord8 2 >> put ctor >> put tipes
|
||||||
EmptyRecord ->
|
|
||||||
putWord8 3
|
|
||||||
Record fs ext ->
|
Record fs ext ->
|
||||||
putWord8 4 >> put fs >> put ext
|
putWord8 3 >> put fs >> put ext
|
||||||
|
|
||||||
get = do
|
get = do
|
||||||
n <- getWord8
|
n <- getWord8
|
||||||
|
@ -94,6 +82,5 @@ instance Binary Type where
|
||||||
0 -> Lambda <$> get <*> get
|
0 -> Lambda <$> get <*> get
|
||||||
1 -> Var <$> get
|
1 -> Var <$> get
|
||||||
2 -> Data <$> get <*> get
|
2 -> Data <$> get <*> get
|
||||||
3 -> return EmptyRecord
|
3 -> Record <$> get <*> get
|
||||||
4 -> Record <$> get <*> get
|
|
||||||
_ -> error "Error reading a valid type from serialized string"
|
_ -> error "Error reading a valid type from serialized string"
|
||||||
|
|
|
@ -47,8 +47,7 @@ renameType renamer tipe =
|
||||||
Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
|
Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
|
||||||
Type.Var _ -> return tipe
|
Type.Var _ -> return tipe
|
||||||
Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
|
Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
|
||||||
Type.EmptyRecord -> return tipe
|
Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
|
||||||
Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext
|
|
||||||
where rnm' (f,t) = (,) f <$> rnm t
|
where rnm' (f,t) = (,) f <$> rnm t
|
||||||
|
|
||||||
metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
|
metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
|
||||||
|
|
|
@ -102,8 +102,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
|
||||||
T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
|
T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
|
||||||
T.Var x -> Set.singleton x
|
T.Var x -> Set.singleton x
|
||||||
T.Data _ ts -> Set.unions (map freeVars ts)
|
T.Data _ ts -> Set.unions (map freeVars ts)
|
||||||
T.EmptyRecord -> Set.empty
|
T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
|
||||||
T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
|
where ext' = maybe Set.empty Set.singleton ext
|
||||||
|
|
||||||
undeclared tvars tipes = Set.difference used declared
|
undeclared tvars tipes = Set.difference used declared
|
||||||
where
|
where
|
||||||
|
@ -147,8 +147,7 @@ infiniteTypeAliases decls =
|
||||||
T.Lambda a b -> infinite a || infinite b
|
T.Lambda a b -> infinite a || infinite b
|
||||||
T.Var _ -> False
|
T.Var _ -> False
|
||||||
T.Data name' ts -> name == name' || any infinite ts
|
T.Data name' ts -> name == name' || any infinite ts
|
||||||
T.EmptyRecord -> False
|
T.Record fields _ -> any (infinite . snd) fields
|
||||||
T.Record fields ext -> infinite ext || any (infinite . snd) fields
|
|
||||||
|
|
||||||
indented :: D.Declaration -> Doc
|
indented :: D.Declaration -> Doc
|
||||||
indented decl = P.text "\n " <> pretty decl <> P.text "\n"
|
indented decl = P.text "\n " <> pretty decl <> P.text "\n"
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Type.Alias (realias, rules, canonicalRealias, Rules) where
|
module Type.Alias (realias, rules, canonicalRealias, Rules) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
@ -30,10 +31,9 @@ localizer moduleImports = go
|
||||||
go tipe =
|
go tipe =
|
||||||
case tipe of
|
case tipe of
|
||||||
Var _ -> tipe
|
Var _ -> tipe
|
||||||
EmptyRecord -> tipe
|
|
||||||
Lambda t1 t2 -> Lambda (go t1) (go t2)
|
Lambda t1 t2 -> Lambda (go t1) (go t2)
|
||||||
Data name ts -> Data (localize name) (map go ts)
|
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)
|
byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
|
||||||
Map.empty moduleImports
|
Map.empty moduleImports
|
||||||
|
@ -83,10 +83,9 @@ canonicalRealias aliases tipe =
|
||||||
tipe' =
|
tipe' =
|
||||||
case tipe of
|
case tipe of
|
||||||
Var _ -> tipe
|
Var _ -> tipe
|
||||||
EmptyRecord -> tipe
|
|
||||||
Lambda t1 t2 -> Lambda (f t1) (f t2)
|
Lambda t1 t2 -> Lambda (f t1) (f t2)
|
||||||
Data name ts -> Data name (map f ts)
|
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 [] = True
|
||||||
allEqual (x:xs) = all (==x) xs
|
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
|
Lambda t1 t2 -> numFields t1 + numFields t2
|
||||||
Var _ -> 0
|
Var _ -> 0
|
||||||
Data _ ts -> sum (map numFields ts)
|
Data _ ts -> sum (map numFields ts)
|
||||||
EmptyRecord -> 0
|
Record fields _ -> length fields + sum (map (numFields . snd) fields)
|
||||||
Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext
|
|
||||||
|
|
||||||
diff :: Type -> Type -> Maybe [(String,Type)]
|
diff :: Type -> Type -> Maybe [(String,Type)]
|
||||||
diff general specific =
|
diff general specific =
|
||||||
|
@ -113,11 +111,11 @@ diff general specific =
|
||||||
(Data gname gts, Data sname sts)
|
(Data gname gts, Data sname sts)
|
||||||
| gname == sname && length gts == length sts ->
|
| gname == sname && length gts == length sts ->
|
||||||
concat <$> zipWithM diff gts sts
|
concat <$> zipWithM diff gts sts
|
||||||
(EmptyRecord, EmptyRecord) -> Just []
|
(Record [] Nothing, Record [] Nothing) -> Just []
|
||||||
(Record _ _, Record _ _) ->
|
(Record _ _, Record [] Nothing) -> Nothing
|
||||||
let (gfs,gext) = collectRecords general
|
(Record [] Nothing, Record _ _) -> Nothing
|
||||||
(sfs,sext) = collectRecords specific
|
(Record gfs gext, Record sfs sext) ->
|
||||||
gfields = collectFields gfs
|
let gfields = collectFields gfs
|
||||||
sfields = collectFields sfs
|
sfields = collectFields sfs
|
||||||
|
|
||||||
overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
|
overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
|
||||||
|
@ -126,10 +124,12 @@ diff general specific =
|
||||||
case isAligned of
|
case isAligned of
|
||||||
False -> Nothing
|
False -> Nothing
|
||||||
True -> let remaining = Map.difference sfields gfields
|
True -> let remaining = Map.difference sfields gfields
|
||||||
sext' = if Map.null remaining then sext else
|
sext' = case sext of
|
||||||
Record (flattenFields remaining) sext
|
Just x | Map.null remaining -> Var x
|
||||||
|
_ -> Record (flattenFields remaining) sext
|
||||||
|
gext' = maybe (Record [] Nothing) Var gext
|
||||||
matchMap = Map.intersectionWith (zipWith diff) gfields sfields
|
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
|
(_,_) -> Nothing
|
||||||
|
|
||||||
collectFields fields =
|
collectFields fields =
|
||||||
|
|
|
@ -28,17 +28,15 @@ toDefs decl =
|
||||||
TypeAlias name _ tipe@(T.Record fields ext) _ ->
|
TypeAlias name _ tipe@(T.Record fields ext) _ ->
|
||||||
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
|
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
|
||||||
where
|
where
|
||||||
args = case ext of
|
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
|
||||||
T.EmptyRecord -> map snd fields
|
|
||||||
_ -> map snd fields ++ [ext]
|
|
||||||
|
|
||||||
var = L.none . E.Var
|
var = L.none . E.Var
|
||||||
vars = take (length args) arguments
|
vars = take (length args) arguments
|
||||||
|
|
||||||
efields = zip (map fst fields) (map var vars)
|
efields = zip (map fst fields) (map var vars)
|
||||||
record = case ext of
|
record = case ext of
|
||||||
T.EmptyRecord -> L.none $ E.Record efields
|
Nothing -> L.none $ E.Record efields
|
||||||
_ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) 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,
|
-- Type aliases must be added to an extended equality dictionary,
|
||||||
-- but they do not require any basic constraints.
|
-- but they do not require any basic constraints.
|
||||||
|
|
|
@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType
|
||||||
_ -> error $ "\nCould not find type constructor '" ++
|
_ -> error $ "\nCould not find type constructor '" ++
|
||||||
name ++ "' while checking types."
|
name ++ "' while checking types."
|
||||||
|
|
||||||
Src.EmptyRecord -> return (TermN EmptyRecord1)
|
Src.Record fields ext -> do
|
||||||
|
fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
|
||||||
Src.Record fields ext ->
|
ext' <- case ext of
|
||||||
TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)
|
Nothing -> return $ TermN EmptyRecord1
|
||||||
|
Just x -> go (Src.Var x)
|
||||||
|
return $ TermN (Record1 fields' ext')
|
|
@ -96,7 +96,6 @@ portTypes rules expr =
|
||||||
| otherwise -> throw $ err msg "Elm values"
|
| otherwise -> throw $ err msg "Elm values"
|
||||||
T.Var _ -> throw $ err msg "type variables"
|
T.Var _ -> throw $ err msg "type variables"
|
||||||
T.Lambda _ _ -> throw $ err msg "Elm functions"
|
T.Lambda _ _ -> throw $ err msg "Elm functions"
|
||||||
T.EmptyRecord -> throw $ err msg "Elm records"
|
|
||||||
T.Record _ _ -> throw $ err msg "Elm records"
|
T.Record _ _ -> throw $ err msg "Elm records"
|
||||||
where
|
where
|
||||||
okay ctor = and [ List.isPrefixOf "JavaScript." ctor
|
okay ctor = and [ List.isPrefixOf "JavaScript." ctor
|
||||||
|
|
|
@ -364,11 +364,15 @@ toSrcType variable = do
|
||||||
return (Src.Data name (ts ++ [b']))
|
return (Src.Data name (ts ++ [b']))
|
||||||
Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
|
Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
|
||||||
Var1 a -> toSrcType a
|
Var1 a -> toSrcType a
|
||||||
EmptyRecord1 -> return Src.EmptyRecord
|
EmptyRecord1 -> return $ Src.Record [] Nothing
|
||||||
Record1 fs ext -> do
|
Record1 tfields extension -> do
|
||||||
fs' <- traverse (mapM toSrcType) fs
|
fields' <- traverse (mapM toSrcType) tfields
|
||||||
let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]
|
let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
|
||||||
Src.Record fs'' <$> toSrcType ext
|
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 ->
|
Nothing ->
|
||||||
case name desc of
|
case name desc of
|
||||||
Just x@(c:_) | Char.isLower c -> return (Src.Var x)
|
Just x@(c:_) | Char.isLower c -> return (Src.Var x)
|
||||||
|
|
Loading…
Reference in a new issue