b16e876 · elk · git.iko.soy

compiler/Type/Constrain/Expression.hs+12−12

@@ -47,7 +47,7 @@ constrain env (A region expr) tipe =

4747 else record (Map.map (\t -> [glTipe t]) decls) baseRec

4848 attribute = makeRec Lit.attribute attr

4949 uniform = makeRec Lit.uniform unif

50− varying = makeRec Lit.varying (TermN EmptyRecord1)

50+ varying = makeRec Lit.varying (termN EmptyRecord1)

5151 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

5252

5353 Var var

@@ -107,7 +107,7 @@ constrain env (A region expr) tipe =

107107

108108 Data name exprs ->

109109 do vars <- forM exprs $ \_ -> liftIO (var Flexible)

110− let pairs = zip exprs (map VarN vars)

110+ let pairs = zip exprs (map varN vars)

111111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

112112 return $ ex vars (cs /\ name <? ctipe)

113113 where

@@ -134,27 +134,27 @@ constrain env (A region expr) tipe =

134134 Modify e fields ->

135135 exists $ \t -> do

136136 oldVars <- forM fields $ \_ -> liftIO (var Flexible)

137− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

138138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

139139

140140 newVars <- forM fields $ \_ -> liftIO (var Flexible)

141− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

142142 let cNew = tipe === record newFields t

143143

144− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

145145

146146 return $ cOld /\ ex newVars (and (cNew : cs))

147147

148148 Record fields ->

149149 do vars <- forM fields $ \_ -> liftIO (var Flexible)

150− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

151− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

152− recordType = record fields' (TermN EmptyRecord1)

150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

152+ recordType = record fields' (termN EmptyRecord1)

153153 return . ex vars . and $ tipe === recordType : cs

154154

155155 Markdown _ _ es ->

156156 do vars <- forM es $ \_ -> liftIO (var Flexible)

157− let tvars = map VarN vars

157+ let tvars = map varN vars

158158 cs <- zipWithM (constrain env) es tvars

159159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

160160

@@ -182,7 +182,7 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

182182 case (pattern, maybeTipe) of

183183 (P.Var name, Just tipe) -> do

184184 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

185− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

186186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

187187 (vars, typ) <- Env.instantiateType env tipe Map.empty

188188 let scheme = Scheme { rigidQuantifiers = [],

@@ -199,8 +199,8 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

199199

200200 (P.Var name, Nothing) -> do

201201 v <- liftIO $ var Flexible

202− let tipe = VarN v

203− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

202+ let tipe = varN v

203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

204204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

205205 c <- constrain env' expr tipe

206206 return ( schemes

compiler/Type/Constrain/Literal.hs+1−1

@@ -15,7 +15,7 @@ constrain env region literal tipe =

1515

1616 litType =

1717 case literal of

18− IntNum _ -> VarN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` var (Is Number)

1919 FloatNum _ -> prim "Float"

2020 Chr _ -> prim "Char"

2121 Str _ -> prim "String"

compiler/Type/Constrain/Pattern.hs+3−3

@@ -36,9 +36,9 @@ constrain env pattern tipe =

3636 P.Var name -> do

3737 v <- liftIO $ var Flexible

3838 return $ Fragment {

39− typeEnv = Map.singleton name (VarN v),

39+ typeEnv = Map.singleton name (varN v),

4040 vars = [v],

41− typeConstraint = VarN v === tipe

41+ typeConstraint = varN v === tipe

4242 }

4343

4444 P.Alias name p -> do

@@ -66,7 +66,7 @@ constrain env pattern tipe =

6666

6767 P.Record fields -> do

6868 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

69− let tenv = Map.fromList (map (second VarN) pairs)

69+ let tenv = Map.fromList (map (second varN) pairs)

7070 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

7171 return $ Fragment {

7272 typeEnv = tenv,

compiler/Type/Environment.hs+17−13

@@ -44,12 +44,12 @@ makeTypes datatypes =

4444 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

4545 makeImported (var, _) = do

4646 tvar <- namedVar Constant var

47− return (V.toString var, VarN tvar)

47+ return (V.toString var, varN tvar)

4848

4949 makeBuiltin :: (String, Int) -> IO (String, Type)

5050 makeBuiltin (name, _) = do

5151 name' <- namedVar Constant (V.builtin name)

52− return (name, VarN name')

52+ return (name, varN name')

5353

5454 builtins :: [(String, Int)]

5555 builtins = concat [ map tuple [0..9]

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

7272 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

7373 inst numTVars tipe = do

7474 vars <- forM [1..numTVars] $ \_ -> var Flexible

75− let (args, result) = tipe (map VarN vars)

75+ let (args, result) = tipe (map (varN) vars)

7676 return (length args, vars, args, result)

7777

7878 tupleCtor n =

@@ -132,24 +132,28 @@ instantiator env sourceType = go sourceType

132132 T.Var x -> do

133133 dict <- State.get

134134 case Map.lookup x dict of

135− Just v -> return (VarN v)

135+ Just v -> return (varN v)

136136 Nothing ->

137− do var <- State.liftIO $ namedVar flex (V.local x)

138− State.put (Map.insert x var dict)

139− return (VarN var)

137+ do v <- State.liftIO $ namedVar flex (V.local x)

138+ State.put (Map.insert x v dict)

139+ return (varN v)

140140 where

141141 flex | "number" `isPrefixOf` x = Is Number

142142 | "comparable" `isPrefixOf` x = Is Comparable

143143 | "appendable" `isPrefixOf` x = Is Appendable

144144 | otherwise = Flexible

145145

146− T.Aliased _ t -> go t

146+ T.Aliased name t -> do

147+ t' <- go t

148+ case t' of

149+ VarN _ v -> return (VarN (Just name) v)

150+ TermN _ term -> return (TermN (Just name) term)

147151

148− T.Type var ->

149− case Map.lookup (V.toString var) (types env) of

152+ T.Type name ->

153+ case Map.lookup (V.toString name) (types env) of

150154 Just t -> return t

151155 Nothing -> error $ "Could not find type constructor '" ++

152− V.toString var ++ "' while checking types."

156+ V.toString name ++ "' while checking types."

153157

154158 T.App t ts -> do

155159 t' <- go t

@@ -159,6 +163,6 @@ instantiator env sourceType = go sourceType

159163 T.Record fields ext -> do

160164 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

161165 ext' <- case ext of

162− Nothing -> return $ TermN EmptyRecord1

166+ Nothing -> return $ termN EmptyRecord1

163167 Just x -> go x

164− return $ TermN (Record1 fields' ext')

168+ return $ termN (Record1 fields' ext')

compiler/Type/Inference.hs+2−2

@@ -41,7 +41,7 @@ infer interfaces modul = unsafePerformIO $ do

4141 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

4242

4343 fvar <- liftIO $ T.var T.Flexible

44− c <- TcExpr.constrain env (program moduleBody) (T.VarN fvar)

44+ c <- TcExpr.constrain env (program moduleBody) (T.varN fvar)

4545 return (header, environ c)

4646

4747 case attemptConstraint of

@@ -62,7 +62,7 @@ canonicalizeValues :: Env.Environment -> (String, Interface)

6262canonicalizeValues env (moduleName, iface) =

6363 forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do

6464 tipe' <- Env.instantiateType env tipe Map.empty

65− return (moduleName ++ "." ++ name, tipe')

65+ return (moduleName ++ "." ++ name, tipe')

6666

6767canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

6868canonicalizeAdts interfaces modul =

compiler/Type/State.hs+25−21

@@ -104,17 +104,20 @@ introduce variable = do

104104flatten :: Type -> StateT SolverState IO Variable

105105flatten term =

106106 case term of

107− VarN v -> return v

108− TermN t -> do

107+ VarN alias v -> do

108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = alias }

109+ return v

110+ TermN alias t -> do

109111 flatStructure <- traverseTerm flatten t

110112 pool <- getPool

111− var <- liftIO . UF.fresh $ Descriptor {

112− structure = Just flatStructure,

113− rank = maxRank pool,

114− flex = Flexible,

115− name = Nothing,

116− copy = Nothing,

117− mark = noMark

113+ var <- liftIO . UF.fresh $ Descriptor

114+ { structure = Just flatStructure

115+ , rank = maxRank pool

116+ , flex = Flexible

117+ , name = Nothing

118+ , copy = Nothing

119+ , mark = noMark

120+ , alias = alias

118121 }

119122 register var

120123

@@ -140,18 +143,19 @@ makeCopy alreadyCopied variable = do

140143

141144 | otherwise -> do

142145 pool <- getPool

143− newVar <- liftIO $ UF.fresh $ Descriptor {

144− structure = Nothing,

145− rank = maxRank pool,

146− mark = noMark,

147− flex = case flex desc of

148− Is s -> Is s

149− _ -> Flexible,

150− copy = Nothing,

151− name = case flex desc of

152− Rigid -> Nothing

153− _ -> name desc

154− }

146+ newVar <- liftIO $ UF.fresh $ Descriptor

147+ { structure = Nothing

148+ , rank = maxRank pool

149+ , mark = noMark

150+ , flex = case flex desc of

151+ Is s -> Is s

152+ _ -> Flexible

153+ , copy = Nothing

154+ , name = case flex desc of

155+ Rigid -> Nothing

156+ _ -> name desc

157+ , alias = Nothing

158+ }

155159 register newVar

156160

157161 -- Link the original variable to the new variable. This lets us

compiler/Type/Type.hs+31−17

@@ -13,6 +13,7 @@ import Control.Monad.State

1313import Control.Monad.Error

1414import Data.Traversable (traverse)

1515import AST.Annotation

16+import qualified AST.PrettyPrint as PP

1617import qualified AST.Type as T

1718import qualified AST.Variable as Var

1819

@@ -25,12 +26,18 @@ data Term1 a

2526 deriving Show

2627

2728data TermN a

28− = VarN a

29− | TermN (Term1 (TermN a))

29+ = VarN (Maybe Var.Canonical) a

30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))

3031 deriving Show

3132

33+varN :: a -> TermN a

34+varN = VarN Nothing

35+

36+termN :: (Term1 (TermN a)) -> TermN a

37+termN = TermN Nothing

38+

3239record :: Map.Map String [TermN a] -> TermN a -> TermN a

33−record fs rec = TermN (Record1 fs rec)

40+record fs rec = termN (Record1 fs rec)

3441

3542type Type = TermN Variable

3643type Variable = UF.Point Descriptor

@@ -71,9 +78,9 @@ a@(A _ c1) /\ b@(A _ c2) =

7178

7279infixr 9 ==>

7380(==>) :: Type -> Type -> Type

74−a ==> b = TermN (Fun1 a b)

81+a ==> b = termN (Fun1 a b)

7582

76−f <| a = TermN (App1 f a)

83+f <| a = termN (App1 f a)

7784

7885data Descriptor = Descriptor

7986 { structure :: Maybe (Term1 Variable)

@@ -82,6 +89,7 @@ data Descriptor = Descriptor

8289 , name :: Maybe TypeName

8390 , copy :: Maybe Variable

8491 , mark :: Int

92+ , alias :: Maybe Var.Canonical

8593 } deriving Show

8694

8795noRank = -1

@@ -104,6 +112,7 @@ namedVar flex name = UF.fresh $ Descriptor

104112 , name = Just name

105113 , copy = Nothing

106114 , mark = noMark

115+ , alias = Nothing

107116 }

108117

109118var :: Flex -> IO Variable

@@ -114,6 +123,7 @@ var flex = UF.fresh $ Descriptor

114123 , name = Nothing

115124 , copy = Nothing

116125 , mark = noMark

126+ , alias = Nothing

117127 }

118128

119129

@@ -130,12 +140,12 @@ fl rqs constraint@(A ann _) =

130140exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

131141exists f = do

132142 v <- liftIO $ var Flexible

133− ex [v] <$> f (VarN v)

143+ ex [v] <$> f (varN v)

134144

135145existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

136146existsNumber f = do

137147 v <- liftIO $ var (Is Number)

138− ex [v] <$> f (VarN v)

148+ ex [v] <$> f (varN v)

139149

140150

141151instance Show a => Show (UF.Point a) where

@@ -185,9 +195,13 @@ instance PrettyType a => PrettyType (Term1 a) where

185195instance PrettyType a => PrettyType (TermN a) where

186196 pretty when term =

187197 case term of

188− VarN x -> pretty when x

189− TermN t1 -> pretty when t1

190−

198+ VarN alias x -> either alias (pretty when x)

199+ TermN alias t1 -> either alias (pretty when t1)

200+ where

201+ either maybeAlias doc =

202+ case maybeAlias of

203+ Just alias -> PP.pretty alias

204+ Nothing -> doc

191205

192206instance PrettyType Descriptor where

193207 pretty when desc =

@@ -321,8 +335,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

321335instance Crawl t => Crawl (TermN t) where

322336 crawl nextState tipe =

323337 case tipe of

324− VarN x -> VarN <$> crawl nextState x

325− TermN term -> TermN <$> crawl nextState term

338+ VarN a x -> VarN a <$> crawl nextState x

339+ TermN a term -> TermN a <$> crawl nextState term

326340

327341instance Crawl t => Crawl (Term1 t) where

328342 crawl nextState term =

@@ -355,7 +369,7 @@ toSrcType :: Variable -> IO T.CanonicalType

355369toSrcType variable =

356370 do desc <- UF.descriptor =<< addNames variable

357371 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

358− return srcType

372+ return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

359373 where

360374 backupSrcType desc =

361375 case name desc of

@@ -402,11 +416,11 @@ collectApps variable = go [] variable

402416 desc <- UF.descriptor variable

403417 case (structure desc, vars) of

404418 (Nothing, [v]) -> case name desc of

405− Just n | Var.isList n -> return (List v)

406− _ -> return Other

419+ Just n | Var.isList n -> return (List v)

420+ _ -> return Other

407421 (Nothing, vs) -> case name desc of

408− Just n | Var.isTuple n -> return (Tuple vs)

409− _ -> return Other

422+ Just n | Var.isTuple n -> return (Tuple vs)

423+ _ -> return Other

410424 (Just term, _) -> case term of

411425 App1 a b -> go (vars ++ [b]) a

412426 _ -> return Other

compiler/Type/Unify.hs+32−15

@@ -1,6 +1,7 @@

11{-# OPTIONS_GHC -W #-}

22module Type.Unify (unify) where

33

4+import Control.Applicative ((<|>))

45import Control.Monad.State

56import qualified Data.List as List

67import qualified Data.Map as Map

@@ -51,32 +52,48 @@ actuallyUnify region variable1 variable2 = do

5152 rank' :: Int

5253 rank' = min (rank desc1) (rank desc2)

5354

55+ alias' :: Maybe Var.Canonical

56+ alias' = alias desc1 <|> alias desc2

57+

5458 merge1 :: StateT TS.SolverState IO ()

5559 merge1 = liftIO $ do

5660 if rank desc1 < rank desc2 then UF.union variable2 variable1

5761 else UF.union variable1 variable2

5862 UF.modifyDescriptor variable1 $ \desc ->

59− desc { structure = structure desc1, flex = flex', name = name' }

63+ desc { structure = structure desc1

64+ , flex = flex'

65+ , name = name'

66+ , alias = alias'

67+ }

6068

6169 merge2 :: StateT TS.SolverState IO ()

6270 merge2 = liftIO $ do

6371 if rank desc1 < rank desc2 then UF.union variable2 variable1

6472 else UF.union variable1 variable2

6573 UF.modifyDescriptor variable2 $ \desc ->

66− desc { structure = structure desc2, flex = flex', name = name' }

74+ desc { structure = structure desc2

75+ , flex = flex'

76+ , name = name'

77+ , alias = alias'

78+ }

6779

6880 merge = if rank desc1 < rank desc2 then merge1 else merge2

6981

7082 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

7183 fresh structure = do

72− var <- liftIO . UF.fresh $ Descriptor {

73− structure = structure, rank = rank', flex = flex',

74− name = name', copy = Nothing, mark = noMark

75− }

76− TS.register var

77−

78− flexAndUnify var = do

79− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

84+ v <- liftIO . UF.fresh $ Descriptor

85+ { structure = structure

86+ , rank = rank'

87+ , flex = flex'

88+ , name = name'

89+ , copy = Nothing

90+ , mark = noMark

91+ , alias = alias'

92+ }

93+ TS.register v

94+

95+ flexAndUnify v = do

96+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

8097 unify' variable1 variable2

8198

8299 unifyNumber svar (Var.Canonical home name) =

@@ -94,10 +111,10 @@ actuallyUnify region variable1 variable2 = do

94111 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

95112 where msg = "An appendable must be of type String, List, or Text."

96113

97− unifyComparable var (Var.Canonical home name) =

114+ unifyComparable v (Var.Canonical home name) =

98115 case home of

99− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify var

100− Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify var

116+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

117+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

101118 _ -> comparableError Nothing

102119

103120 unifyComparableStructure varSuper varFlex =

@@ -122,8 +139,8 @@ actuallyUnify region variable1 variable2 = do

122139

123140 rigidError variable = TS.addError region (Just hint) variable1 variable2

124141 where

125− var = "'" ++ render (pretty Never variable) ++ "'"

126− hint = "Cannot unify rigid type variable " ++ var ++

142+ v = "'" ++ render (pretty Never variable) ++ "'"

143+ hint = "Cannot unify rigid type variable " ++ v ++

127144 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

128145 \variables are not shared between a top-level and let-bound type annotations."

129146