760ad90 · elk · git.iko.soy

compiler/Parse/Type.hs+1−1

compare with master

unifiedsplit

@@ -29,7 +29,7 @@ record =

29 ext <- extend

30 fs <- fields

31 dumbWhitespace ; char '}'

32− return (T.Record (fieldMap fs) ext)

32+ return (T.Record fs ext)

33 where

34 extend = option T.EmptyRecord . try $ do

35 t <- tvar

compiler/SourceSyntax/Module.hs+1−1

@@ -98,4 +98,4 @@ renameType find tipe =

98 Var x -> Var x

99 Data name ts -> Data (find name) (map rnm ts)

100 EmptyRecord -> EmptyRecord

101− Record fields ext -> Record (Map.map (map rnm) fields) (rnm ext)

101+ Record fields ext -> Record (map (second rnm) fields) (rnm ext)

compiler/SourceSyntax/Type.hs+4−4

@@ -13,7 +13,7 @@ data Type = Lambda Type Type

13 | Var String

14 | Data String [Type]

15 | EmptyRecord

16− | Record (Map.Map String [Type]) Type

16+ | Record [(String,Type)] Type

17 deriving (Eq, Show, Data, Typeable)

18

19fieldMap :: [(String,Type)] -> Map.Map String [Type]

@@ -21,7 +21,7 @@ fieldMap fields =

21 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

22

23recordOf :: [(String,Type)] -> Type

24−recordOf fields = Record (fieldMap fields) EmptyRecord

24+recordOf fields = Record fields EmptyRecord

25

26listOf :: Type -> Type

27listOf t = Data "_List" [t]

@@ -43,8 +43,8 @@ instance Pretty Type where

43 EmptyRecord -> P.braces P.empty

44 Record fields ext -> P.braces $ P.hang (pretty ext <+> P.text "|") 4 prettyFields

45 where

46− prettyField (f,ts) = map (\t -> P.text f <+> P.text ":" <+> pretty t) ts

46+ prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

47− prettyFields = commaSep . concatMap prettyField $ Map.toList fields

47+ prettyFields = commaSep . map prettyField $ fields

48

49collectLambdas tipe =

50 case tipe of

compiler/Type/Constrain/Declaration.hs+28−7

@@ -23,15 +23,29 @@ toDefs decl =

23 Datatype name tvars constructors -> concatMap toDefs constructors

24 where

25 toDefs (ctor, tipes) =

26− let vars = take (length tipes) $ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

26+ let vars = take (length tipes) arguments

27− loc = Src.none

27+ tbody = Type.Data name $ map Type.Var tvars

28− body = loc . Src.Data ctor $ map (loc . Src.Var) vars

28+ body = Src.none . Src.Data ctor $ map (Src.none . Src.Var) vars

29− in [ Src.TypeAnnotation ctor $

29+ in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

30− foldr Type.Lambda (Type.Data name $ map Type.Var tvars) tipes

31− , Src.Def (Src.PVar ctor) $

30+ , Src.Def (Src.PVar ctor) $ buildFunction body vars

32− foldr (\p e -> loc $ Src.Lambda p e) body (map Src.PVar vars)

33 ]

31 ]

34

32

33+ TypeAlias name tvars tipe@(Type.Record fields ext) ->

34+ [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

35+ , Src.Def (Src.PVar name) $ buildFunction record vars ]

36+ where

37+ args = case ext of

38+ Type.EmptyRecord -> map snd fields

39+ _ -> map snd fields ++ [ext]

40+

41+ var = Src.none . Src.Var

42+ vars = take (length args) arguments

43+

44+ efields = zip (map fst fields) (map var vars)

45+ record = Src.none $ case ext of

46+ Type.EmptyRecord -> Src.Record efields

47+ _ -> Src.Modify (var $ last vars) efields

48+

35 -- Type aliases must be added to an extended equality dictionary,

49 -- Type aliases must be added to an extended equality dictionary,

36 -- but they do not require any basic constraints.

50 -- but they do not require any basic constraints.

37 TypeAlias _ _ _ -> []

51 TypeAlias _ _ _ -> []

@@ -45,3 +59,10 @@ toDefs decl =

45

59

46 -- no constraints are needed for fixity declarations

60 -- no constraints are needed for fixity declarations

47 Fixity _ _ _ -> []

61 Fixity _ _ _ -> []

62+

63+

64+arguments :: [String]

65+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

66+

67+buildFunction body vars =

68+ foldr (\p e -> Src.none (Src.Lambda p e)) body (map Src.PVar vars)

compiler/Type/Environment.hs+1−1

@@ -160,4 +160,4 @@ instantiator env sourceType = go sourceType

160 Src.EmptyRecord -> return (TermN EmptyRecord1)

161

162 Src.Record fields ext ->

163− TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)

163+ TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)