module Data.Model.Types(
TypeModel(..),TypeEnv,typeADTs
,ADT(..)
,ConTree(..),Fields
,Type(..),TypeN(..),nestedTypeNs,TypeRef(..)
,Name(..),QualName(..),qualName
,adtNamesMap
,typeN,typeA
,contree,constructors,constructorInfo,conTreeNameMap,conTreeNameFold,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.Either.Validation
import qualified Data.Map as M
import Data.Maybe
import Data.Model.Util
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 :: Fields name ref
}
| ConTree (ConTree name ref) (ConTree name ref)
deriving (Eq, Ord, Show, NFData, Generic)
type Fields name ref = Either
[Type ref]
[(name,Type ref)]
constructors :: ConTree name ref -> [(name, Fields name ref)]
constructors (Con n f) = [(n,f)]
constructors (ConTree l r) = constructors l ++ constructors r
contree :: [(name, Fields name ref)] -> Maybe (ConTree name ref)
contree [] = Nothing
contree ccs = Just . ct $ ccs
where
ct [(name,fields)] = Con name fields
ct cs = let (ls,rs) = splitAt (length cs `div` 2) cs in ConTree (ct ls) (ct rs)
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)
conTreeNameFold :: Monoid a => (name -> a) -> ConTree name t -> a
conTreeNameFold f (ConTree l r) = conTreeNameFold f l `mappend` conTreeNameFold f r
conTreeNameFold f (Con n _) = f n
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)
nestedTypeNs :: TypeN t -> [TypeN t]
nestedTypeNs t@(TypeN _ []) = [t]
nestedTypeNs t@(TypeN _ ps) = t : concatMap nestedTypeNs ps
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 = convert $ n {pkgName=""}
instance Convertible String QualName where safeConvert = errorsToConvertResult (validationToEither . asQualName)
instance Convertible QualName String where safeConvert n = Right $ dotted [pkgName n,mdlName n,locName n]
asQualName :: String -> Validation Errors QualName
asQualName =
(\n ->
if nullQualName n
then Failure ["Empty qualified name"]
else Success n) .
asQualName_
where
nullQualName n = pkgName n == "" && mdlName n == "" && locName n == ""
asQualName_ n =
let (p, r) = span (/= '.') n
in if null r
then QualName "" "" p
else let (l, r2) = span (/= '.') $ reverse $ tail r
in if null r2
then QualName "" p (reverse l)
else let m = reverse $ tail r2
in QualName p m (reverse l)
data Name = Name String deriving (Eq, Ord, Show, NFData, Generic)
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,"in",show $ M.keys e]) (M.lookup k e)