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
import Control.Monad
import qualified Data.Set as S
import Text.Megaparsec.Text
import Text.Megaparsec.Prim
import Text.Megaparsec.Error
data SemanticError = OverloadedReturns | CircularFunctionCalls T.Text T.Text | InsufficientArgs Int Int
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 (InsufficientArgs i j) = show $ semErrStart <> text "Insufficent arguments from the command line, given " <> (text . show $ i) <> ", expected at least " <> (text . show $ j)
instance Exception SemanticError where
customError :: String -> Parser a
customError = failure S.empty S.empty . S.singleton . representFail
overloadedReturns :: Parser a
overloadedReturns = customError . show $ OverloadedReturns
circularFunctionCalls :: T.Text -> T.Text -> Parser a
circularFunctionCalls f1 f2 = customError . show $ CircularFunctionCalls f1 f2
insufficientArgs :: Int -> Int -> Parser a
insufficientArgs i j = customError . show $ InsufficientArgs i j
semErrStart :: Doc
semErrStart = dullred (text "\n Semantic Error: ")
text' :: T.Text -> Doc
text' = text . T.unpack
checkSemantics :: [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])]
checkSemantics = foldr (<=<) pure [ checkReturn
]
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)
access :: [a] -> Int -> a
access xs i = if (i >= length xs) then throw (InsufficientArgs (length xs) (i+1)) else xs !! i
checkReturn :: [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])]
checkReturn keys
| singleReturn keys = pure keys
| otherwise = overloadedReturns
singleReturn :: [(Key, [(Prob, [PreTok])])] -> Bool
singleReturn = singleton . (filter ((=="Template") . fst))
where singleton [a] = True
singleton _ = False