module Language.FunPat.Match where

import System.IO.Unsafe
import Control.Exception
import Data.Typeable
import Data.Maybe

-- * Matchability

-- | A data type to be used in 'Matchable' instances.
data Match where
    (:=:)   :: (Matchable a) => a -> a -> Match

-- | 'Matchable' data types can be used in patterns.
class (Typeable a) => Matchable a where
    -- | The conditions of a match. In most cases, this is the only function in this class to implement.
    --
    -- If the result is @Nothing@, there is no match.
    --
    -- If the result is @Just [x :=: x\', y :=: y\', ... ]@, condition of the match is
    -- that @x@ matches @x\'@, @y@ matches @y\'@ etc.
    (.=.)   :: a -> a -> Maybe [Match]
    -- | Creates an extra value of type @a@ with a @Bool@ inside.
    --
    -- The default implementation throws an exception.
    makeParam   :: Bool -> a
    makeParam b = throw $ SomeException $ Param b
    -- | Checks if the argument is an extra value created by 'makeParam'.
    --
    -- The default implementation evaluates the argument and catches the
    -- exception thrown.
    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

-- * Implementation

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

-- | @Case@ instances are allowed to form cases of a pattern match. (Normally, there is no need to implement more instances of this class.)
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)

-- | Processes one case.
matchSomeCase :: pat -> SomeCase (pat, res) -> Maybe res
matchSomeCase x (SomeCase c) = matchCase x c

-- | Processes multiple cases.
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

-- * Helper functions

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