module Language.FunPat.Match where
import System.IO.Unsafe
import Control.Exception
import Data.Typeable
import Data.Maybe
data Match where
(:=:) :: (Matchable a) => a -> a -> Match
class (Typeable a) => Matchable a where
(.=.) :: a -> a -> Maybe [Match]
makeParam :: Bool -> a
makeParam b = throw $ SomeException $ Param b
isParam :: a -> Maybe Bool
isParam x = unsafePerformIO $ do
result <- try $ evaluate x
case result of
Left e -> return $ fmap fromParam $ fromException e
Right _ -> return Nothing
data Param = Param { fromParam :: Bool }
deriving Typeable
instance Show Param where
show _ = package ++ unbound
instance Exception Param where
toException b = SomeException b
fromException (SomeException p) = cast p
class Matchable (PatternType t) => Case t where
type PatternType t
type ResultType t
type ParameterType t
start :: PatternType t -> t -> Maybe (ParameterType t)
continue :: Typeable p => PatternType t -> t -> p -> Maybe [p]
matchCase :: PatternType t -> t -> Maybe (ResultType t)
instance (Matchable u, Typeable u) => Case (u,v) where
type PatternType (u,v) = u
type ResultType (u,v) = v
type ParameterType (u,v) = ()
start = matchError "Internal error."
continue val (pat, _) p = matchHelp (pat :=: val) p
matchCase val (pat,res) = case matchHelp (pat :=: val) () of
Nothing -> Nothing
Just _ -> Just res
instance (Typeable p, Matchable p, Case u) => Case (p -> u) where
type PatternType (p -> u) = PatternType u
type ResultType (p -> u) = ResultType u
type ParameterType (p -> u) = p
start val pat = case continue val (pat p) p of
Nothing -> Nothing
Just [] -> matchError nonlinear
Just [x] -> case continue val (pat x) p of
Just [] -> Just x
_ -> matchError nonparametric
Just (x:xs) -> matchError nonlinear
where
p = makeParam True
continue val pat p = continue val (pat $ makeParam False) p
matchCase val pat = case start val pat of
Nothing -> Nothing
Just x -> matchCase val $ pat x
data SomeCase t where
SomeCase :: (Case a) => a -> SomeCase (PatternType a, ResultType a)
matchSomeCase :: pat -> SomeCase (pat, res) -> Maybe res
matchSomeCase x (SomeCase c) = matchCase x c
matchCases :: pat -> [SomeCase (pat, res)] -> res
matchCases x cs = case catMaybes $ map (matchSomeCase x) cs of
[] -> matchError "No match."
(x:_) -> x
matchHelp :: (Typeable p) => Match -> p -> Maybe [p]
matchHelp (pat :=: val) p = case isParam pat of
Just True -> case cast val of
Nothing -> matchError nonparametric
Just x -> Just [x]
Just False -> Just []
Nothing -> case pat .=. val of
Nothing -> Nothing
Just xs -> matchFold p xs
matchFold :: Typeable p => p -> [Match] -> Maybe [p]
matchFold p [] = Just []
matchFold p (x:xs) = case (matchHelp x p, matchFold p xs) of
(Nothing, _) -> Nothing
(_, Nothing) -> Nothing
(Just ps, Just qs) -> Just $ ps ++ qs
package :: String
package = "Language.FunPat: "
unbound :: String
unbound = "Unbound variable."
nonlinear :: String
nonlinear = "Nonlinear pattern."
nonparametric :: String
nonparametric = "Nonparametric pattern."
matchError :: String -> a
matchError e = error $ package ++ e