module Data.Model.Types(
TypeModel(..),TypeEnv,typeADTs
,ADT(..)
,ConTree(..)
,Type(..),TypeN(..),TypeRef(..)
,Name(..),QualName(..),qualName
,adtNamesMap
--,typeADTs
,typeN,typeA
,constructors,constructorInfo,conTreeNameMap,conTreeTypeMap,conTreeTypeList,conTreeTypeFoldMap,fieldsTypes,fieldsNames
,HTypeEnv,HTypeModel,HADT,HType,HTypeRef
,solve,solveAll,unVar,getHRef
,module GHC.Generics,Proxy(..)
) where
import Control.Applicative
import Control.DeepSeq
import Data.Bifunctor (first, second)
import Data.List
import qualified Data.ListLike.String as S
import qualified Data.Map as M
import Data.Maybe
import Data.Proxy
import Data.Word (Word8)
import GHC.Generics
type HTypeEnv = TypeEnv String String (TypeRef QualName) QualName
type HTypeModel = TypeModel String String (TypeRef QualName) QualName
type HADT = ADT String String HTypeRef
type HType = Type HTypeRef
type HTypeRef = TypeRef QualName
data TypeModel adtName consName inRef exRef = TypeModel {
typeName::Type exRef
,typeEnv::TypeEnv adtName consName inRef exRef
}
deriving (Eq, Ord, Show, NFData, Generic)
typeADTs :: TypeModel adtName consName inRef k -> [ADT adtName consName inRef]
typeADTs = M.elems . typeEnv
type TypeEnv adtName consName inRef exRef = M.Map exRef (ADT adtName consName inRef)
data ADT name consName ref =
ADT
{ declName :: name
, declNumParameters :: Word8
, declCons :: Maybe (ConTree consName ref)
}
deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable)
data ConTree name ref =
Con {
constrName :: name
,constrFields :: Either
[Type ref]
[(name,Type ref)]
}
| ConTree (ConTree name ref) (ConTree name ref)
deriving (Eq, Ord, Show, NFData, Generic)
constructors :: ConTree t t1 -> [ConTree t t1]
constructors c@(Con _ _) = [c]
constructors (ConTree l r) = constructors l ++ constructors r
fieldsTypes :: Either [b] [(a, b)] -> [b]
fieldsTypes (Left ts) = ts
fieldsTypes (Right nts) = map snd nts
fieldsNames :: Either t [(a, t1)] -> [t1]
fieldsNames (Left _) = []
fieldsNames (Right nts) = map snd nts
constructorInfo :: Eq consName => consName -> ConTree consName t -> Maybe ([Bool], [Type t])
constructorInfo consName = (first reverse <$>) . loc []
where
loc bs (Con n ps) | n == consName = Just (bs,fieldsTypes ps)
| otherwise = Nothing
loc bs (ConTree l r) = loc (False:bs) l <|> loc (True:bs) r
instance Functor (ConTree name) where
fmap f (ConTree l r) = ConTree (fmap f l) (fmap f r)
fmap f (Con n (Left ts)) = Con n (Left $ (fmap . fmap) f ts)
fmap f (Con n (Right ts)) = Con n (Right $ (fmap . fmap . fmap) f ts)
instance Foldable (ConTree name) where
foldMap f (ConTree l r) = foldMap f l `mappend` foldMap f r
foldMap f (Con _ (Left ts)) = mconcat . map (foldMap f) $ ts
foldMap f (Con _ (Right nts)) = mconcat . map (foldMap f . snd) $ nts
instance Traversable (ConTree name) where
traverse f (ConTree l r) = ConTree <$> traverse f l <*> traverse f r
traverse f (Con n (Left ts)) = Con n . Left <$> sequenceA (map (traverse f) ts)
traverse f (Con n (Right nts)) = Con n . Right . zip (map fst nts) <$> sequenceA (map (traverse f . snd) nts)
conTreeTypeMap :: (Type t -> Type ref) -> ConTree name t -> ConTree name ref
conTreeTypeMap f (ConTree l r) = ConTree (conTreeTypeMap f l) (conTreeTypeMap f r)
conTreeTypeMap f (Con n (Left ts)) = Con n (Left $ map f ts)
conTreeTypeMap f (Con n (Right nts)) = Con n (Right $ map (second f) nts)
conTreeNameMap :: (name -> name2) -> ConTree name t -> ConTree name2 t
conTreeNameMap f (ConTree l r) = ConTree (conTreeNameMap f l) (conTreeNameMap f r)
conTreeNameMap f (Con n (Left ts)) = Con (f n) (Left ts)
conTreeNameMap f (Con n (Right nts)) = Con (f n) (Right $ map (first f) nts)
conTreeTypeList :: ConTree name t -> [Type t]
conTreeTypeList = conTreeTypeFoldMap (:[])
conTreeTypeFoldMap :: Monoid a => (Type t -> a) -> ConTree name t -> a
conTreeTypeFoldMap f (ConTree l r) = conTreeTypeFoldMap f l `mappend` conTreeTypeFoldMap f r
conTreeTypeFoldMap f (Con _ (Left ts)) = mconcat . map f $ ts
conTreeTypeFoldMap f (Con _ (Right nts)) = mconcat . map (f . snd) $ nts
adtNamesMap
:: (adtName1 -> adtName2)
-> (consName1 -> consName2)
-> ADT adtName1 consName1 ref
-> ADT adtName2 consName2 ref
adtNamesMap f g adt = adt {declName = f (declName adt),declCons = conTreeNameMap g <$> declCons adt}
data Type ref = TypeCon ref
| TypeApp (Type ref) (Type ref)
deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable)
data TypeN r = TypeN r [TypeN r]
deriving (Eq,Ord,Read,Show,NFData ,Generic,Functor,Foldable,Traversable)
typeN :: Type r -> TypeN r
typeN (TypeApp f a) = let TypeN h ts = typeN f
in TypeN h (ts ++ [typeN a])
typeN (TypeCon r) = TypeN r []
typeA :: TypeN ref -> Type ref
typeA (TypeN tf ts) = foldl TypeApp (TypeCon tf) (map typeA ts)
data TypeRef name = TypVar Word8
| TypRef name
deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable)
unVar :: TypeRef t -> t
unVar (TypVar _) = error "Unexpected variable"
unVar (TypRef n) = n
getHRef :: TypeRef a -> Maybe a
getHRef (TypRef r) = Just r
getHRef (TypVar _) = Nothing
data QualName = QualName {pkgName,mdlName,locName :: String}
deriving (Eq, Ord, Show, NFData, Generic)
qualName :: QualName -> String
qualName n = concat [mdlName n,".",locName n]
instance S.StringLike QualName where
toString n = intercalate "." [pkgName n,mdlName n,locName n]
fromString n = let (p,r) = span (/= '.') n
(m,r2) = span (/= '.') $ tail r
l = tail r2
in QualName p m l
instance S.StringLike String where
toString = id
fromString = id
data Name = Name String deriving (Eq, Ord, Show, NFData, Generic)
instance S.StringLike Name where
toString (Name n)= n
fromString = Name
solveAll :: (Functor f, Show k, Ord k) => M.Map k b -> f k -> f b
solveAll env t = (`solve` env) <$> t
solve :: (Ord k, Show k) => k -> M.Map k a -> a
solve k e = fromMaybe (error $ unwords ["solve:Unknown reference to",show k]) (M.lookup k e)