a8da548 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP: type inference

a8da548AgentM11 years ago

ProjectM36/Atom.hs+2

compare with master

unifiedsplit

@@ -63,3 +63,5 @@ atomToText :: Atom -> T.Text

63atomToText (Atom atom) = toText atom

64atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

66+

67+

ProjectM36/AtomType.hs+47−19

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

1{-# LANGUAGE OverloadedStrings #-}

2module ProjectM36.AtomType where

3import ProjectM36.Base

4−import ProjectM36.Relation

5import ProjectM36.DataTypes.Primitive

4import ProjectM36.DataTypes.Primitive

6import qualified ProjectM36.TypeConstructorDef as TCD

5import qualified ProjectM36.TypeConstructorDef as TCD

7import qualified ProjectM36.TypeConstructor as TC

6import qualified ProjectM36.TypeConstructor as TC

@@ -9,30 +8,14 @@ import qualified ProjectM36.DataConstructorDef as DCD

9import qualified Data.Text as T

8import qualified Data.Text as T

10import ProjectM36.Error

9import ProjectM36.Error

11import ProjectM36.Attribute

10import ProjectM36.Attribute

12−import ProjectM36.Atom

13import qualified Data.Vector as V

11import qualified Data.Vector as V

14import qualified Data.Set as S

12import qualified Data.Set as S

15import qualified Data.List as L

13import qualified Data.List as L

16import Data.Maybe (isJust)

14import Data.Maybe (isJust)

17import Control.Monad.Writer

15import Control.Monad.Writer

18import qualified Data.Map as M

16import qualified Data.Map as M

19−--import Debug.Trace

17+import Debug.Trace

21−typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation

22−typesAsRelation types = mkRelationFromTuples attrs tuples

23− where

24− attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,

25− Attribute "DataConstructors" dConsType]

26− subAttrs = attributesFromList [Attribute "DataConstructor" textAtomType]

27− dConsType = RelationAtomType subAttrs

28− tuples = map mkTypeConsDescription types

29−

30− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TCD.name tCons), mkDataConsRelation dConsList])

31−

32− mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

33− Left err -> error ("mkRelationFromTuples pooped " ++ show err)

34− Right rel -> Atom rel

35−

36findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)

19findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)

37findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

20findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

38 where

21 where

@@ -89,6 +72,7 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes = do

89 Just (tCons, dCons) -> do

72 Just (tCons, dCons) -> do

90 --validate that the type constructor arguments are fulfilled in the data constructor

73 --validate that the type constructor arguments are fulfilled in the data constructor

91 typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

74 typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

75+ traceShowM typeVars

92 pure (ConstructedAtomType (TCD.name tCons) typeVars)

76 pure (ConstructedAtomType (TCD.name tCons) typeVars)

94-- | Walks the data and type constructors to extract the type variable map.

78-- | Walks the data and type constructors to extract the type variable map.

@@ -96,6 +80,9 @@ resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstr

96resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

80resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

97 maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

81 maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

98 --if any two maps have the same key and different values- bail!

82 --if any two maps have the same key and different values- bail!

83+ let typeVarMapFolder

84+ foldr typeVarMapFolder (Right M.empty) maps

85+ --if the data constructor cannot complete a type constructor variables (ex. "Nothing" could be Maybe Int or Maybe Text, etc.), then fill that space with AnyAtomType which is resolved when the relation is constructed- the relation must contain all resolved atom types.

99 pure (M.unions maps)

86 pure (M.unions maps)

100

101-- | Attempt to match the data constructor argument to a type constructor type variable.

88-- | Attempt to match the data constructor argument to a type constructor type variable.

@@ -147,6 +134,7 @@ dupes (x:y:xs) = dupes(x:[y]) ++ dupes(xs)

147-- | Create an atom type iff all type variables are provided.

134-- | Create an atom type iff all type variables are provided.

148-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

135-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}

149atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType

136atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType

137+atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType

150atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of

138atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of

151 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

139 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

152 Just (tConsDef, _) -> do

140 Just (tConsDef, _) -> do

@@ -166,4 +154,44 @@ findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

166 Just (tCons, dConsList)

154 Just (tCons, dConsList)

167 else

155 else

168 accum

156 accum

169−

157+

158+resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

159+resolveAtomType orig@(ConstructedAtomType dConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

160+ _ <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

161+ pure orig

162+resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

163+ Right typeFromRelation

164+ else

165+ Left (AtomTypeMismatchError typeFromRelation unresolvedType)

166+

167+-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap

168+resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap

169+resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

170+ let lookup key tMap = case M.lookup key tMap of

171+ Nothing -> Left (TypeConstructorTypeVarMissing key)

172+ Just val -> Right val

173+ let resolveTypePair unresKey AnyAtomType = do

174+ resType <- lookup unresKey resolvedTypeMap

175+ pure (unresKey, resType)

176+ resolveTypePair unresKey subType@(ConstructedAtomType _ _) = do --recurse

177+ resType <- lookup unresKey resolvedTypeMap

178+ resAType <- resolveAtomType resType subType

179+ pure (unresKey, resAType)

180+ resolveTypePair unresKey unresV = pure (unresKey, unresV)

181+ mapM_ (uncurry resolveTypePair) (M.toList unresolvedTypeMap)

182+ pure resolvedTypeMap

183+

184+-- | See notes at `resolveTypesInTuple`. The typeFromRelation must not include any wildcards.

185+resolveTypeInAtom :: AtomType -> Atom -> Either RelationalError Atom

186+resolveTypeInAtom typeFromRelation atomIn@(ConstructedAtom dConsName _ args) = do

187+ newType <- resolveAtomType typeFromRelation (atomTypeForAtom atomIn)

188+ pure (ConstructedAtom dConsName newType args)

189+resolveTypeInAtom _ atom = Right atom

190+

191+-- | When creating a tuple, the data constructor may not complete the type constructor arguments, so the wildcard "AnyAtomType" fills in the type constructor's argument. The tuple type must be resolved before it can be part of a relation, however.

192+-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.

193+resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

194+resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

195+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) (map atomType (V.toList resolvedAttrs)))

196+ Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

197+

ProjectM36/Base.hs+1−1

@@ -133,7 +133,7 @@ data AtomType = AtomType ConcreteTypeRep |

133 RelationAtomType Attributes |

134 ConstructedAtomType TypeConstructorName TypeVarMap |

135 AnyAtomType

136− --wildcard used in Atom Functions

136+ --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor

137 deriving (Eq,NFData,Generic,Binary,Show)

138

139type TypeVarMap = M.Map TypeVarName AtomType

ProjectM36/Client.hs+1−1

@@ -59,7 +59,7 @@ import ProjectM36.Attribute hiding (atomTypes)

59import ProjectM36.Persist (DiskSync(..))

60import ProjectM36.Notifications

61import ProjectM36.Server.RemoteCallTypes

62−import ProjectM36.AtomType (typesAsRelation)

62+import ProjectM36.Relation (typesAsRelation)

63import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

64import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)

65import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

ProjectM36/DataTypes/Basic.hs+5−1

@@ -8,7 +8,11 @@ basicTypeConstructorMapping :: TypeConstructorMapping

8basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ moreTypes

9 where

10 moreTypes = [(ADTypeConstructorDef "Day" ["a"],

11− [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]])]

11+ [DataConstructorDef "Day" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" intAtomType)]]),

12+ (ADTypeConstructorDef "Maybe" ["a"],

13+ [DataConstructorDef "Nothing" [],

14+ DataConstructorDef "Just" [DataConstructorDefTypeVarNameArg "a"]])

15+ ]

ProjectM36/Error.hs+1

@@ -41,6 +41,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

41 | DataConstructorNameInUseError DataConstructorName

42 | DataConstructorUsesUndeclaredTypeVariable TypeVarName

43 | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)

44+ | TypeConstructorTypeVarMissing TypeVarName

44 | AtomTypeNameInUseError AtomTypeName

45 | AtomTypeNameInUseError AtomTypeName

45 | IncompletelyDefinedAtomTypeWithConstructorError

46 | IncompletelyDefinedAtomTypeWithConstructorError

46 | AtomTypeNameNotInUseError AtomTypeName

47 | AtomTypeNameNotInUseError AtomTypeName

ProjectM36/Relation.hs+22−1

@@ -4,14 +4,20 @@ import qualified Data.Set as S

4import qualified Data.HashSet as HS

5import Control.Monad

6import qualified Data.Vector as V

7+import ProjectM36.Atom

7import ProjectM36.Base

8import ProjectM36.Base

8import ProjectM36.Tuple

9import ProjectM36.Tuple

10+import ProjectM36.DataTypes.Primitive

9import qualified ProjectM36.Attribute as A

11import qualified ProjectM36.Attribute as A

10import qualified ProjectM36.AttributeNames as AS

12import qualified ProjectM36.AttributeNames as AS

11import ProjectM36.TupleSet

13import ProjectM36.TupleSet

12import ProjectM36.Error

14import ProjectM36.Error

13import qualified Control.Parallel.Strategies as P

15import qualified Control.Parallel.Strategies as P

16+import qualified ProjectM36.TypeConstructorDef as TCD

17+import qualified ProjectM36.DataConstructorDef as DCD

18+import qualified Data.Text as T

14import Data.Either (isRight)

19import Data.Either (isRight)

20+import Debug.Trace

16attributes :: Relation -> Attributes

22attributes :: Relation -> Attributes

17attributes (Relation attrs _ ) = attrs

23attributes (Relation attrs _ ) = attrs

@@ -71,7 +77,7 @@ singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then

71union :: Relation -> Relation -> Either RelationalError Relation

77union :: Relation -> Relation -> Either RelationalError Relation

72union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

78union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

73 if not (A.attributesEqual attrs1 attrs2)

79 if not (A.attributesEqual attrs1 attrs2)

74− then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))

80+ then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference (traceShowId attrs1) (traceShowId attrs2)))

75 else

81 else

76 Right $ Relation attrs1 newtuples

82 Right $ Relation attrs1 newtuples

77 where

83 where

@@ -257,5 +263,20 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe

257 tupleSetJoiner tup1 acc = undefined

263 tupleSetJoiner tup1 acc = undefined

258-}

264-}

259

265

266+typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation

267+typesAsRelation types = mkRelationFromTuples attrs tuples

268+ where

269+ attrs = A.attributesFromList [Attribute "TypeConstructor" textAtomType,

270+ Attribute "DataConstructors" dConsType]

271+ subAttrs = A.attributesFromList [Attribute "DataConstructor" textAtomType]

272+ dConsType = RelationAtomType subAttrs

273+ tuples = map mkTypeConsDescription types

274+

275+ mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [textAtom (TCD.name tCons), mkDataConsRelation dConsList])

276+

277+ mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

278+ Left err -> error ("mkRelationFromTuples pooped " ++ show err)

279+ Right rel -> Atom rel

280+

260

281

261

282

ProjectM36/Relation/Show/Term.hs+22−6

@@ -4,10 +4,13 @@ module ProjectM36.Relation.Show.Term where

4import ProjectM36.Base

5import ProjectM36.Tuple

6import ProjectM36.Relation

7−import qualified Data.Set as S

7+import ProjectM36.Attribute

8+import ProjectM36.ConcreteTypeRep

8import qualified Data.List as L

9import qualified Data.List as L

9import qualified Data.Text as T

10import qualified Data.Text as T

11+import qualified Data.Vector as V

12+import qualified Data.Map as M

10−import Data.Typeable (cast)

13+import Data.Typeable (cast, tyConName, splitTyConApp)

12boxV :: StringType

15boxV :: StringType

13boxV = "│"

16boxV = "│"

@@ -78,18 +81,28 @@ cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . brea

78 L.maximumBy compare (lengths row)

81 L.maximumBy compare (lengths row)

79 lengths row = map T.length (breakLines row)

82 lengths row = map T.length (breakLines row)

80 allRows = [header] ++ body

83 allRows = [header] ++ body

84+

85+attributeAsCell :: Attribute -> Cell

86+attributeAsCell attr = attributeName attr `T.append` "::" `T.append` prettyAtomType (atomType attr)

87+

88+prettyAtomType :: AtomType -> T.Text

89+prettyAtomType (AtomType primitiveType) = T.pack (tyConName (fst (splitTyConApp (unCTR primitiveType))))

90+prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map attributeAsCell (V.toList attrs)) `T.append` "}"

91+prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` " " `T.append` T.pack (show (M.toList typeVarMap)) -- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

92+prettyAtomType AnyAtomType = "?AnyAtomType?"

82relationAsTable :: Relation -> Table

94relationAsTable :: Relation -> Table

83relationAsTable rel@(Relation _ tupleSet) = (header, body)

95relationAsTable rel@(Relation _ tupleSet) = (header, body)

84 where

96 where

97+ oAttrs = orderedAttributes rel

85− oAttrs = orderedAttributeNames rel

98+ oAttrNames = orderedAttributeNames rel

86− header = oAttrs

99+ header = map attributeAsCell oAttrs

87 body :: [[Cell]]

100 body :: [[Cell]]

88 body = L.foldl' tupleFolder [] (asList tupleSet)

101 body = L.foldl' tupleFolder [] (asList tupleSet)

89 tupleFolder acc tuple = acc ++ [map (\attrName -> case atomForAttributeName attrName tuple of

102 tupleFolder acc tuple = acc ++ [map (\attrName -> case atomForAttributeName attrName tuple of

90 Left _ -> "?"

103 Left _ -> "?"

91 Right atom -> showAtom atom

104 Right atom -> showAtom atom

92− ) oAttrs]

105+ ) oAttrNames]

106

94showAtom :: Atom -> StringType

107showAtom :: Atom -> StringType

95showAtom (Atom atom) = case cast atom of

108showAtom (Atom atom) = case cast atom of

@@ -135,8 +148,11 @@ renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar

135 rowHeightMatrix = zip cellMatrix (tail rowLocations)

148 rowHeightMatrix = zip cellMatrix (tail rowLocations)

136 renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations

149 renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations

137

150

151+orderedAttributes :: Relation -> [Attribute]

152+orderedAttributes rel = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributes rel))

153+

138orderedAttributeNames :: Relation -> [AttributeName]

154orderedAttributeNames :: Relation -> [AttributeName]

139−orderedAttributeNames = S.toAscList . attributeNames

155+orderedAttributeNames rel = map attributeName (orderedAttributes rel)

140

156

141repeatString :: Int -> StringType -> StringType

157repeatString :: Int -> StringType -> StringType

142repeatString c s = T.concat (take c (repeat s))

158repeatString c s = T.concat (take c (repeat s))

ProjectM36/Tuple.hs+1

@@ -200,3 +200,4 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

200 mapper attr = case atomForAttributeName (attributeName attr) tupIn of

201 Left _ -> undefined

202 Right atom -> atom

203+

ProjectM36/TypeConstructorDef.hs−1

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

1module ProjectM36.TypeConstructorDef where

2import ProjectM36.Base

3−import qualified Data.Set as S

5name :: TypeConstructorDef -> TypeConstructorName

4name :: TypeConstructorDef -> TypeConstructorName

6name (ADTypeConstructorDef nam _) = nam

5name (ADTypeConstructorDef nam _) = nam