module Text.Madlibs.Cata.SemErr where
import Text.Madlibs.Internal.Types
import Data.Typeable
import Text.PrettyPrint.ANSI.Leijen
import Control.Exception
import qualified Data.Text as T
data SemanticError = OverloadedReturns | CircularFunctionCalls T.Text T.Text | ProbSum T.Text
deriving (Typeable)
instance Show SemanticError where
show OverloadedReturns = show $ semErrStart <> text "File contains multiple declarations of :return"
show (CircularFunctionCalls f1 f2) = show $ semErrStart <> text "Circular function declaration between:" <> indent 4 (yellow $ (text' f1) <> (text ", ") <> (text' f2))
show (ProbSum f) = show $ semErrStart <> text "Function's options do not sum to 1:\n" <> indent 4 (yellow (text' f))
semErrStart :: Doc
semErrStart = dullred (text "\n Semantic Error: ")
text' :: T.Text -> Doc
text' = text . T.unpack
instance Exception SemanticError
checkSemantics :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])]
checkSemantics = foldr (.) id [ checkProb
, checkReturn ]
checkProb :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])]
checkProb = map (\(i,j) -> if sumProb j then (i,j) else throw (ProbSum i))
sumProb :: [(Prob, [PreTok])] -> Bool
sumProb = ((==1) . sum . (map fst))
head' :: T.Text -> T.Text -> [a] -> a
head' _ _ (x:xs) = x
head' f1 f2 _ = throw (CircularFunctionCalls f1 f2)
checkReturn :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])]
checkReturn keys
| singleReturn keys = keys
| otherwise = throw OverloadedReturns
singleReturn :: [(Key, [(Prob, [PreTok])])] -> Bool
singleReturn = singleton . (filter ((=="Template") . fst))
where singleton = not . null