module Language.Clafer.IG.Sugarer (sugarClaferModel) where
import Language.Clafer.Common
import Language.Clafer.IG.ClaferModel
import Data.Maybe (fromJust)
import Data.List as List hiding (map)
import Data.Map as Map hiding (map, foldr, foldl)
import Prelude hiding (id)
data Census = Census
(Map Id (Int, String))
(Map String Int)
deriving Show
poll :: Id -> Census -> Census
poll id (Census sample' counts') =
Census sample'' counts''
where
fullName = i_name id
name = makeSimpleName fullName
counts'' = insertWith (+) name 1 counts'
ordinal' = findWithDefault (error $ "Did not find " ++ name ++ " in counts.") name counts''
sample'' = insertWith (error $ "Polled " ++ fullName ++ " twice in the census.") id (ordinal', name) sample'
makeSimpleName :: String -> String
makeSimpleName name' = case dropWhile (/='_') name' of
"" -> error "Unexpected Clafer name " ++ name'
x -> tail x
claferModelCensus :: ClaferModel -> Census
claferModelCensus (ClaferModel topLevelClafers) =
clafersCensus (Census Map.empty Map.empty) topLevelClafers
where
clafersCensus = foldl claferCensus
claferCensus census Clafer{c_id=id, c_children=children} = poll id (clafersCensus census children)
sugarClaferModel:: Bool -> Bool -> UIDIClaferMap -> ClaferModel -> (Map Int String) -> ClaferModel
sugarClaferModel useUids addTypes uidIClaferMap' model@(ClaferModel topLevelClafers) sMap =
ClaferModel $ map sugarClafer topLevelClafers
where
sugarClafer (Clafer id value children) =
Clafer (sugarId useUids addTypes True id) (sugarValue (Clafer id value children)) (map sugarClafer children)
sugarValue (Clafer _ (Just (AliasValue alias)) _) = Just $ AliasValue $ sugarId useUids addTypes False alias
sugarValue (Clafer _ Nothing _) = Nothing
sugarValue c = if (cType c) == "string" then (Just ((StringValue) (getString c))) else (c_value c)
cType (Clafer id _ _) = cTypeSolve $ getReference iclafer
where
iclafer = fromJust $ findIClafer uidIClaferMap' $ i_name id
cTypeSolve ["string"] = "string"
cTypeSolve ["integer"] = "integer"
cTypeSolve ["int"] = "integer"
cTypeSolve ["real"] = "real"
cTypeSolve _ = ""
getString c = case (Map.lookup strNumber sMap) of
Nothing -> "\"<text " ++ show strNumber ++ ">\""
Just s -> s
where strNumber = v_value $ fromJust $ c_value c
Census sample' counts' = claferModelCensus model
sugarId :: Bool -> Bool -> Bool -> Id -> Id
sugarId useUids' addTypes' addRefDecl id =
Id (finalName ++ ordinalDisplay ++ (refDecl addTypes' addRefDecl uidIClaferMap')) 0
where
fullName = i_name id
ordinalDisplay = if (useUids || count > 1)
then "$" ++ show ordinal
else ""
refDecl :: Bool -> Bool -> UIDIClaferMap -> String
refDecl True True uidIClaferMap'' = retrieveSuper uidIClaferMap'' $ i_name id
refDecl _ _ _ = ""
(ordinal, simpleName) = findWithDefault (error $ "Sample lookup " ++ show id ++ " failed.") id sample'
count = findWithDefault (error $ "Count lookup " ++ simpleName ++ " failed.") simpleName counts'
finalName = if useUids' then fullName else simpleName
retrieveSuper :: UIDIClaferMap -> String -> String
retrieveSuper uidIClaferMap' uid =
sugarSuper (getSuper iclafer)
++
sugarReference (getReference iclafer)
where
iclafer = fromJust $ findIClafer uidIClaferMap' uid
sugarSuper :: [String] -> String
sugarSuper [s] = " : " ++ s
sugarSuper _ = ""
sugarReference :: [String] -> String
sugarReference [s] = " -> " ++ s
sugarReference _ = ""