83e8bad · elk · git.iko.soy

compiler/Build/Source.hs+4−4

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

4141 | null exs =

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

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

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

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

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

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

4646 | otherwise = exs

4747

4848 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

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

5353 -- reorder AST into strongly connected components

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

5555 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 ],

5757 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 ],

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

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

6161 }

compiler/Docs.hs+11−6

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

1717

1818import SourceSyntax.Helpers (isSymbol)

1919import SourceSyntax.Type (Type(..))

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

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

2121import SourceSyntax.Expression (Def(..))

2222

2323import Text.Parsec hiding (newline,spaces)

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

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

135135 Definition (TypeAnnotation name tipe) ->

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

137− TypeAlias name vars tipe ->

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

137+ TypeAlias name vars tipe derivations ->

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

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

140− Datatype name vars ctors ->

140+ Datatype name vars ctors derivations ->

141141 let tipe = Data name (map Var vars)

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

142+ fields = ["typeVariables" .= vars

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

144+ , "deriving" .= derivations ]

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

144146 where

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

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

160162

161163ctorToJson tipe (ctor, tipes) =

162164 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

2929 padded equals

3030 tipe <- Type.expr

3131 json <- option [] $ do

32− padded (reserved "deriving")

32+ try $ padded (reserved "deriving")

3333 string "Json"

3434 return [D.Json]

3535 return (D.TypeAlias alias args tipe json)

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

4242 args <- spacePrefix lowVar

4343 padded equals

4444 tcs <- pipeSep1 Type.constructor

45− return $ D.Datatype name args tcs

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

4646

4747

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

compiler/SourceSyntax/Declaration.hs+29−13

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

11module SourceSyntax.Declaration where

22

3+import Data.Binary

34import qualified SourceSyntax.Expression as Expr

45import SourceSyntax.Type

56import SourceSyntax.PrettyPrint

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

78

89data Declaration tipe var

910 = Definition (Expr.Def tipe var)

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

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

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

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

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

1314 | ExportEvent String String Type

1415 | Fixity Assoc Int String

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

1718data Assoc = L | N | R

1819 deriving (Eq)

1920

20−data Deriveable = Json | Binary | RecordConstructor

21+data Derivation = Json | Binary | RecordConstructor

2122 deriving (Eq, Show)

2223

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+

2337instance Show Assoc where

2438 show assoc =

2539 case assoc of

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

3246 case decl of

3347 Definition def -> pretty def

3448

35− Datatype tipe tvars ctors ->

49+ Datatype tipe tvars ctors deriveables ->

3650 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

3852 where

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

4054 prettyCtor (name, tipes) =

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

4256

4357 TypeAlias name tvars tipe deriveables ->

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

58+ alias <+> prettyDeriving deriveables

4559 where

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

47− deriving' =

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)

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

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

5362

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

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

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

5766 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 {

4949 program :: LExpr t v,

5050 types :: Map.Map String Type,

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

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

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

52+ aliases :: [Alias],

53+ datatypes :: [ADT],

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

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

5656} deriving Show

5757

5858type 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])

6061

6162data ModuleInterface = ModuleInterface {

6263 iVersion :: Version.Version,

6364 iTypes :: Map.Map String Type,

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

6566 iAdts :: [ADT],

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

67+ iAliases :: [Alias],

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

6869} deriving Show

6970

compiler/Transform/Canonicalize.hs+13−9

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

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

2727 }

2828 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)

3030 prefix name = moduleName ++ "." ++ name

3131

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

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

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

3434 canons = Map.fromList $ concat

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

3636

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

5656 [] -> Right ()

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

5858 program' <- rename initialEnv (program modul)

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

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

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

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

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

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

6363 return $ modul { program = program'

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

6868 where

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

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

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

72− d' <- g d

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

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

72+ do c' <- f c

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

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

75+ do b' <- f b

76+ d' <- g d

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

7478 renameType' =

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

7680

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

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

7882 canon (name, importMethod) =

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

8084 iface = ifaces Map.! name

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

8286 , map get1 (iAliases iface)

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

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

8488 in case importMethod of

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

8690 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]

7474duplicateConstructors decls =

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

7676 where

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

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

7878 dataCtors = List.sort . concat $

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

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

8080 dataMsg = dupErr "definition of data constructor"

8181 typeMsg = dupErr "definition of type constructor"

8282

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

101101badDerivations decls = concatMap badDerivation derivations

102102 where

103103 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+

105107 badDerivation (decl, tvars, derives) =

106108 case (tvars, derives) of

107109 (_:_, _)

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

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

121123 where

122124 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 ]

124126

125127 freeVars tipe =

126128 case tipe of

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

174176 T.EmptyRecord -> False

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

176178

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

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

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

179181 , indented decl

180182 , P.text $ eightyCharLines 0 msg2

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

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

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

183185 ]

184186 where

compiler/Transform/SafeNames.hs+2−2

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

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

6565 , program = expression (program modul)

6666 , aliases =

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

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

6868 in map makeSafe (aliases modul)

6969 , 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)

7171 in map makeSafe (datatypes modul)

7272 , foreignImports =

7373 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

99import SourceSyntax.Type

1010import SourceSyntax.Module

1111

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

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

1313

1414rules interfaces moduleAliases moduleImports =

1515 (collect interfaces moduleAliases, localizer moduleImports)

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

2020 rawAliases =

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

2222

23− isPrimitive (_,_,tipe) =

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

2424 case tipe of

2525 Data _ [] -> True

2626 _ -> False

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

6262

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

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

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

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

6666canonicalRealias aliases tipe =

6767 case concatMap tryRealias aliases of

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

6969 tipes -> f (bestType tipes)

7070 where

71− tryRealias (name, args, aliasTipe) =

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

7272 case diff aliasTipe tipe of

7373 Nothing -> []

7474 Just kvs ->

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

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

2222 case decl of

2323 Definition def -> [def]

2424

25− Datatype name tvars constructors -> concatMap toDefs constructors

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

2626 where

2727 toDefs (ctor, tipes) =

2828 let vars = take (length tipes) arguments

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

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

3333 ]

3434

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

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

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

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

3838 where

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

5050

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

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

53− TypeAlias _ _ _ -> []

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

54+ TypeAlias _ _ _ _ -> []

5455

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

5657 [ Src.TypeAnnotation name tipe

compiler/Type/Environment.hs+5−5

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

1313import qualified Text.PrettyPrint as PP

1414

1515import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

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

2626 value :: TypeDict

2727}

2828

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

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

3030initialEnvironment datatypes aliases = do

3131 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

3333 env = Environment {

3434 constructor = Map.empty,

3535 value = Map.empty,

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

4242makeTypes datatypes =

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

4444 where

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

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

4646

4747 makeCtor (name, kind) = do

4848 ctor <- VarN <$> namedVar Constant name

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

8484

8585

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

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

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

8888 zip (map fst ctors) (map inst ctors)

8989 where

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