83e8bad · elk · git.iko.soy

compiler/Build/Source.hs+4−4

compare with master

unifiedsplit

@@ -41,8 +41,8 @@ build noPrelude interfaces source =

41 | null exs =

42 let get = Set.toList . SD.boundVars in

43 concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++

44− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

44+ concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++

45− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

45+ [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]

46 | otherwise = exs

47

48 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

@@ -53,9 +53,9 @@ build noPrelude interfaces source =

53 -- reorder AST into strongly connected components

54 program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,

55 types = Map.empty,

56− datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],

56+ datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ],

57 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],

58− aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],

58+ aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ],

59 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],

60 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]

61 }

compiler/Docs.hs+11−6

@@ -17,7 +17,7 @@ import qualified Data.Text as Text

17

18import SourceSyntax.Helpers (isSymbol)

19import SourceSyntax.Type (Type(..))

20−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

20+import SourceSyntax.Declaration (Declaration(..), Assoc(..), Derivation(..))

21import SourceSyntax.Expression (Def(..))

22

23import Text.Parsec hiding (newline,spaces)

@@ -134,12 +134,14 @@ collect infixes types aliases adts things =

134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

135 Definition (TypeAnnotation name tipe) ->

136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

137− TypeAlias name vars tipe ->

137+ TypeAlias name vars tipe derivations ->

138− let fields = ["typeVariables" .= vars, "type" .= tipe ]

138+ let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]

139 in collect infixes types (insert name fields aliases) adts rest

140− Datatype name vars ctors ->

140+ Datatype name vars ctors derivations ->

141 let tipe = Data name (map Var vars)

142+ fields = ["typeVariables" .= vars

142− fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]

143+ , "constructors" .= map (ctorToJson tipe) ctors

144+ , "deriving" .= derivations ]

143 in collect infixes types aliases (insert name fields adts) rest

145 in collect infixes types aliases (insert name fields adts) rest

144 where

146 where

145 insert name fields dict = Map.insert name (obj name fields) dict

147 insert name fields dict = Map.insert name (obj name fields) dict

@@ -160,4 +162,7 @@ instance ToJSON Type where

160

162

161ctorToJson tipe (ctor, tipes) =

163ctorToJson tipe (ctor, tipes) =

162 object [ "name" .= ctor

164 object [ "name" .= ctor

163− , "type" .= foldr Lambda tipe tipes ]

165+ , "type" .= foldr Lambda tipe tipes ]

166+

167+instance ToJSON Derivation where

168+ toJSON = toJSON . show

compiler/Parse/Declaration.hs+2−2

@@ -29,7 +29,7 @@ alias = do

29 padded equals

30 tipe <- Type.expr

31 json <- option [] $ do

32− padded (reserved "deriving")

32+ try $ padded (reserved "deriving")

33 string "Json"

34 return [D.Json]

35 return (D.TypeAlias alias args tipe json)

@@ -42,7 +42,7 @@ datatype = do

42 args <- spacePrefix lowVar

43 padded equals

44 tcs <- pipeSep1 Type.constructor

45− return $ D.Datatype name args tcs

45+ return $ D.Datatype name args tcs []

46

47

48infixDecl :: IParser (D.Declaration t v)

compiler/SourceSyntax/Declaration.hs+29−13

@@ -1,5 +1,6 @@

1module SourceSyntax.Declaration where

2

3+import Data.Binary

3import qualified SourceSyntax.Expression as Expr

4import qualified SourceSyntax.Expression as Expr

4import SourceSyntax.Type

5import SourceSyntax.Type

5import SourceSyntax.PrettyPrint

6import SourceSyntax.PrettyPrint

@@ -7,8 +8,8 @@ import Text.PrettyPrint as P

7

8

8data Declaration tipe var

9data Declaration tipe var

9 = Definition (Expr.Def tipe var)

10 = Definition (Expr.Def tipe var)

10− | Datatype String [String] [(String,[Type])]

11+ | Datatype String [String] [(String,[Type])] [Derivation]

11− | TypeAlias String [String] Type [Deriveable]

12+ | TypeAlias String [String] Type [Derivation]

12 | ImportEvent String (Expr.LExpr tipe var) String Type

13 | ImportEvent String (Expr.LExpr tipe var) String Type

13 | ExportEvent String String Type

14 | ExportEvent String String Type

14 | Fixity Assoc Int String

15 | Fixity Assoc Int String

@@ -17,9 +18,22 @@ data Declaration tipe var

17data Assoc = L | N | R

18data Assoc = L | N | R

18 deriving (Eq)

19 deriving (Eq)

19

20

20−data Deriveable = Json | Binary | RecordConstructor

21+data Derivation = Json | Binary | RecordConstructor

21 deriving (Eq, Show)

22 deriving (Eq, Show)

22

23

24+instance Binary Derivation where

25+ get = do n <- getWord8

26+ return $ case n of

27+ 0 -> Json

28+ 1 -> Binary

29+ 2 -> RecordConstructor

30+

31+ put derivation =

32+ case derivation of

33+ Json -> putWord8 0

34+ Binary -> putWord8 1

35+ RecordConstructor -> putWord8 2

36+

23instance Show Assoc where

37instance Show Assoc where

24 show assoc =

38 show assoc =

25 case assoc of

39 case assoc of

@@ -32,26 +46,28 @@ instance Pretty (Declaration t v) where

32 case decl of

46 case decl of

33 Definition def -> pretty def

47 Definition def -> pretty def

34

48

35− Datatype tipe tvars ctors ->

49+ Datatype tipe tvars ctors deriveables ->

36 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

50 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

37− (P.sep $ zipWith join ("=" : repeat "|") ctors)

51+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables

38 where

52 where

39 join c ctor = P.text c <+> prettyCtor ctor

53 join c ctor = P.text c <+> prettyCtor ctor

40 prettyCtor (name, tipes) =

54 prettyCtor (name, tipes) =

41 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

55 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

42

56

43 TypeAlias name tvars tipe deriveables ->

57 TypeAlias name tvars tipe deriveables ->

44− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe) <+> deriving'

58+ alias <+> prettyDeriving deriveables

45 where

59 where

46− alias = P.text name <+> P.hsep (map P.text tvars)

60+ name' = P.text name <+> P.hsep (map P.text tvars)

47− deriving' =

61+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)

48− case deriveables of

49− [] -> P.empty

50− [d] -> P.text "deriving" <+> P.text (show d)

51− ds -> P.text "deriving" <+>

52− P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

53

62

54 -- TODO: Actually write out the contained data in these cases.

63 -- TODO: Actually write out the contained data in these cases.

55 ImportEvent _ _ _ _ -> P.text (show decl)

64 ImportEvent _ _ _ _ -> P.text (show decl)

56 ExportEvent _ _ _ -> P.text (show decl)

65 ExportEvent _ _ _ -> P.text (show decl)

57 Fixity _ _ _ -> P.text (show decl)

66 Fixity _ _ _ -> P.text (show decl)

67+

68+prettyDeriving deriveables =

69+ case deriveables of

70+ [] -> P.empty

71+ [d] -> P.text "deriving" <+> P.text (show d)

72+ ds -> P.text "deriving" <+>

73+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

compiler/SourceSyntax/Module.hs+5−4

@@ -49,21 +49,22 @@ data MetadataModule t v = MetadataModule {

49 program :: LExpr t v,

50 types :: Map.Map String Type,

51 fixities :: [(Assoc, Int, String)],

52− aliases :: [(String, [String], Type)],

52+ aliases :: [Alias],

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

53+ datatypes :: [ADT],

54 foreignImports :: [(String, LExpr t v, String, Type)],

55 foreignExports :: [(String, String, Type)]

56} deriving Show

57

58type Interfaces = Map.Map String ModuleInterface

59−type ADT = (String, [String], [(String,[Type])])

59+type ADT = (String, [String], [(String,[Type])], [Derivation])

60+type Alias = (String, [String], Type, [Derivation])

60

61

61data ModuleInterface = ModuleInterface {

62data ModuleInterface = ModuleInterface {

62 iVersion :: Version.Version,

63 iVersion :: Version.Version,

63 iTypes :: Map.Map String Type,

64 iTypes :: Map.Map String Type,

64 iImports :: [(String, ImportMethod)],

65 iImports :: [(String, ImportMethod)],

65 iAdts :: [ADT],

66 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

67+ iAliases :: [Alias],

67 iFixities :: [(Assoc, Int, String)]

68 iFixities :: [(Assoc, Int, String)]

68} deriving Show

69} deriving Show

69

70

compiler/Transform/Canonicalize.hs+13−9

@@ -26,11 +26,11 @@ interface moduleName iface =

26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

27 }

28 where

29− both f g (a,b,c) = (f a, b, g c)

29+ both f g (a,b,c,d) = (f a, b, g c, d)

30 prefix name = moduleName ++ "." ++ name

31

32 pair name = (name, moduleName ++ "." ++ name)

33− canon (name,_,_) = pair name

33+ canon (name,_,_,_) = pair name

34 canons = Map.fromList $ concat

35 [ map canon (iAdts iface), map canon (iAliases iface) ]

36

@@ -56,8 +56,8 @@ metadataModule ifaces modul =

56 [] -> Right ()

57 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

58 program' <- rename initialEnv (program modul)

59− aliases' <- mapM (third renameType') (aliases modul)

59+ aliases' <- mapM (threeOfFour renameType') (aliases modul)

60− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

60+ datatypes' <- mapM (threeOfFour (mapM (second (mapM renameType')))) (datatypes modul)

61 exports' <- mapM (third renameType') (foreignExports modul)

62 imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

63 return $ modul { program = program'

@@ -68,19 +68,23 @@ metadataModule ifaces modul =

68 where

69 second f (a,b) = (,) a `fmap` f b

70 third f (a,b,c) = (,,) a b `fmap` f c

71+ threeOfFour f (a,b,c,d) =

72+ do c' <- f c

73+ return (a,b,c',d)

71− twoAndFour f g (a,b,c,d) = do b' <- f b

74+ twoAndFour f g (a,b,c,d) =

75+ do b' <- f b

72− d' <- g d

76+ d' <- g d

73− return (a,b',c,d')

77+ return (a,b',c,d')

74 renameType' =

78 renameType' =

75 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

79 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

76

80

77− get1 (a,_,_) = a

81+ get1 (a,_,_,_) = a

78 canon (name, importMethod) =

82 canon (name, importMethod) =

79 let pair pre var = (pre ++ drop (length name + 1) var, var)

83 let pair pre var = (pre ++ drop (length name + 1) var, var)

80 iface = ifaces Map.! name

84 iface = ifaces Map.! name

81 allNames = concat [ Map.keys (iTypes iface)

85 allNames = concat [ Map.keys (iTypes iface)

82 , map get1 (iAliases iface)

86 , map get1 (iAliases iface)

83− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

87+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

84 in case importMethod of

88 in case importMethod of

85 As alias -> map (pair (alias ++ ".")) allNames

89 As alias -> map (pair (alias ++ ".")) allNames

86 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

90 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

compiler/Transform/Check.hs+8−6

@@ -74,9 +74,9 @@ duplicateConstructors :: [D.Declaration t v] -> [String]

74duplicateConstructors decls =

75 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

76 where

77− typeCtors = List.sort [ name | D.Datatype name _ _ <- decls ]

77+ typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]

78 dataCtors = List.sort . concat $

79− [ map fst patterns | D.Datatype _ _ patterns <- decls ]

79+ [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]

80 dataMsg = dupErr "definition of data constructor"

81 typeMsg = dupErr "definition of type constructor"

82

@@ -101,7 +101,9 @@ badDerivations :: [D.Declaration t v] -> [Doc]

101badDerivations decls = concatMap badDerivation derivations

102 where

103 derivations =

104− [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ]

104+ [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++

105+ [ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]

106+

105 badDerivation (decl, tvars, derives) =

107 badDerivation (decl, tvars, derives) =

106 case (tvars, derives) of

108 case (tvars, derives) of

107 (_:_, _)

109 (_:_, _)

@@ -120,7 +122,7 @@ illFormedTypes :: [D.Declaration t v] -> [Doc]

120illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

122illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

121 where

123 where

122 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

124 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

123− adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]

125+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

124

126

125 freeVars tipe =

127 freeVars tipe =

126 case tipe of

128 case tipe of

@@ -174,11 +176,11 @@ infiniteTypeAliases decls =

174 T.EmptyRecord -> False

176 T.EmptyRecord -> False

175 T.Record fields ext -> infinite ext || any (infinite . snd) fields

177 T.Record fields ext -> infinite ext || any (infinite . snd) fields

176

178

177− report decl@(D.TypeAlias name args tipe _) =

179+ report decl@(D.TypeAlias name args tipe derivations) =

178 P.vcat [ P.text $ eightyCharLines 0 msg1

180 P.vcat [ P.text $ eightyCharLines 0 msg1

179 , indented decl

181 , indented decl

180 , P.text $ eightyCharLines 0 msg2

182 , P.text $ eightyCharLines 0 msg2

181− , indented (D.Datatype name args [(name,[tipe])])

183+ , indented (D.Datatype name args [(name,[tipe])] derivations)

182 , P.text $ eightyCharLines 0 msg3 ++ "\n"

184 , P.text $ eightyCharLines 0 msg3 ++ "\n"

183 ]

185 ]

184 where

186 where

compiler/Transform/SafeNames.hs+2−2

@@ -64,10 +64,10 @@ metadataModule modul =

64 , imports = map (first var) (imports modul)

65 , program = expression (program modul)

66 , aliases =

67− let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)

67+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

68 in map makeSafe (aliases modul)

69 , datatypes =

70− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

70+ let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)

71 in map makeSafe (datatypes modul)

72 , foreignImports =

73 let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)

compiler/Type/Alias.hs+4−4

@@ -9,7 +9,7 @@ import qualified Data.List as List

9import SourceSyntax.Type

10import SourceSyntax.Module

11

12−type Rules = ([(String,[String],Type)], Type -> Type)

12+type Rules = ([Alias], Type -> Type)

13

14rules interfaces moduleAliases moduleImports =

15 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +20,7 @@ collect interfaces moduleAliases =

20 rawAliases =

21 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

22

23− isPrimitive (_,_,tipe) =

23+ isPrimitive (_,_,tipe,_) =

24 case tipe of

25 Data _ [] -> True

26 _ -> False

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62

63-- Realias using canonical aliases, so results will have aliases

64-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

66canonicalRealias aliases tipe =

67 case concatMap tryRealias aliases of

68 [] -> if tipe == tipe' then tipe else f tipe'

69 tipes -> f (bestType tipes)

70 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

72 case diff aliasTipe tipe of

73 Nothing -> []

74 Just kvs ->

compiler/Type/Constrain/Declaration.hs+4−3

@@ -22,7 +22,7 @@ toDefs decl =

22 case decl of

23 Definition def -> [def]

24

25− Datatype name tvars constructors -> concatMap toDefs constructors

25+ Datatype name tvars constructors _ -> concatMap toDefs constructors

26 where

27 toDefs (ctor, tipes) =

28 let vars = take (length tipes) arguments

@@ -32,7 +32,7 @@ toDefs decl =

32 , Src.Def (P.PVar ctor) $ buildFunction body vars

33 ]

34

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

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

36 [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37 , Src.Def (P.PVar name) $ buildFunction record vars ]

38 where

@@ -50,7 +50,8 @@ toDefs decl =

50

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

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

53+ -- TODO: with the ability to derive code, you may need to generate stuff!

53− TypeAlias _ _ _ -> []

54+ TypeAlias _ _ _ _ -> []

54

55

55 ImportEvent _ expr@(L.L s _) name tipe ->

56 ImportEvent _ expr@(L.L s _) name tipe ->

56 [ Src.TypeAnnotation name tipe

57 [ Src.TypeAnnotation name tipe

compiler/Type/Environment.hs+5−5

@@ -13,7 +13,7 @@ import qualified Data.UnionFind.IO as UF

13import qualified Text.PrettyPrint as PP

14

15import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

17import Type.Type

18

19type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

26 value :: TypeDict

27}

28

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30initialEnvironment datatypes aliases = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

32+ let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases

33 env = Environment {

34 constructor = Map.empty,

35 value = Map.empty,

@@ -42,7 +42,7 @@ makeTypes :: [ADT] -> IO TypeDict

42makeTypes datatypes =

43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

44 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

46

47 makeCtor (name, kind) = do

48 ctor <- VarN <$> namedVar Constant name

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

84

85

86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, derivations) =

88 zip (map fst ctors) (map inst ctors)

89 where

90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)