{-# LANGUAGE FlexibleInstances #-}
 
import qualified Control.Monad as M (liftM, ap)
import qualified Data.Foldable as Fld (foldlM, foldrM)
 
main :: IO ()
main = 
    do
        print (buildValidM symTheTree :: (Construction Integer))
 
symTheTree :: SymbolTree
symTheTree = 
    Node Div [                          -- shall create an Integer
        Node Mul [                        -- shall create an Integer
            Node Add [                      -- shall create an Integer
                Node Number [                 -- shall create an Integer (and/or String)
                    Node (Terminal '3') [],     -- shall create a Char
                    Node (Terminal '3') [],     -- shall create a Char
                    Node (Terminal '3') [],     -- shall create a Char
                    Node (Terminal '1') []],    -- shall create a Char
                Node Number [                 -- shall create an Integer (and/or String)
                    Node (Terminal '3') [],     -- shall create a Char
                    Node (Terminal '3') [],     -- shall create a Char
                    Node (Terminal '1') []]],   -- shall create a Char
            Node Sub [                      -- shall create an Integer
                Node Number [                 -- shall create an Integer (and/or String)
                    Node (Terminal '3') [],   -- shall create a Char
                    Node (Terminal '3') [],   -- shall create a Char
                    Node (Terminal '1') []],  -- shall create a Char
                Node Number [               -- shall create an Integer (and/or String)
                    Node (Terminal '1') [],   -- shall create a Char
                    Node (Terminal '3') []]]],-- shall create a Char
        Node Number [                       -- shall create an Integer (and/or String)
            Node (Terminal '7') []]]          -- shall create a Char
 
data SymbolTree = Node Symbol [SymbolTree]
    deriving Show
 
data Symbol = Add | Sub | Mul | Div | Number | Terminal Char
    deriving Show
 
data Construction model = Contains model | Error ErrorKind
    deriving Show
 
data ErrorKind = 
      ErrSymTree { rsInstance :: String, rsPattern :: String }
    | Constraint { rsCase :: String, rsConstraint :: String }
    deriving Show
 
newtype String' = String' String
    deriving Show
 
instance Functor Construction where
    fmap = M.liftM
 
instance Applicative Construction where
    pure = return
    (<*>) = M.ap
 
instance Monad Construction where
    (Contains x) >>= g  = g x
    Error s       >>= _ = Error s
    return              = Contains
 
class Gen g where
    buildValidM :: SymbolTree -> (Construction g)
    buildValidDflt :: g
    buildValid :: SymbolTree -> g
    buildValid symTree = 
        let buildValid' (Error _) = buildValidDflt
            buildValid' (Contains x) = x
        in buildValid' (buildValidM symTree)
    constraint :: (g -> Bool) -> String -> String -> (Construction g) -> (Construction g)
    constraint _ _ _ g@(Error _) = g
    constraint fConstraint sCase sConstraint (Contains g) 
        | fConstraint g = (Contains g)
        | otherwise = Error (Constraint sCase sConstraint)
 
fOpFromSymTree :: (Gen g) => (g -> g -> g) -> (SymbolTree -> g -> Construction g)
fOpFromSymTree fOp trSymA nB = 
    do
        nA <- buildValidM trSymA
        return (fOp nA nB);
 
fOpFlippedFromSymTree :: (Gen g) => (g -> g -> g) -> (g -> SymbolTree -> Construction g)
fOpFlippedFromSymTree fOp nA trSymB = 
    do
        nB <- buildValidM trSymB
        return (fOp nA nB);
 
cmbnNCmt :: (Gen g) => (g -> g -> g) -> g -> [SymbolTree] -> Construction g
cmbnNCmt fOp identity ltrSym = Fld.foldrM (fOpFromSymTree fOp) identity ltrSym
 
cmbnFast :: (Gen g) => (g -> g -> g) -> g -> [SymbolTree] -> Construction g
cmbnFast fOp identity ltrSym = Fld.foldlM (fOpFlippedFromSymTree fOp) identity ltrSym
 
instance Gen String' where
    buildValidDflt = (String' "")
    buildValidM (Node (Terminal ch) _) = Contains (String' [ch])
    buildValidM (Node _ ltrSym) = (cmbnFast (s'concat) (String' "") ltrSym)
 
s'concat :: String' -> String' -> String'
s'concat (String' sA) (String' sB) = String' (sA ++ sB)
 
instance Gen Integer where
    buildValidDflt = 0
    buildValidM symTree@(Node Number _) = (Contains (read (buildValid symTree)))
    buildValidM (Node Add ltrSym) = cnstInt "Add" $ cmbnFast (+) 0 ltrSym
    buildValidM (Node Sub ltrSym) = cnstInt "Sub" $ cmbnNCmt (-) 0 ltrSym
    buildValidM (Node Mul ltrSym) = cnstInt "Mul" $ cmbnFast (*) 1 ltrSym
    buildValidM (Node Div ltrSym) = cnstInt "Div" $ cmbnNCmt (div) 1 ltrSym
    buildValidM _ = Error (ErrSymTree "instance Gen Integer" "buildValidM _")
 
cnstInt :: String -> (Construction Integer) -> (Construction Integer)
cnstInt sCase g = constraint (<= 65535) sCase "smaller than 2^16-1" g
 
instance Gen String where
    buildValidDflt = ""
    buildValidM (Node Number ltrSym) = Contains [ch | (Contains ch) <- (map buildValidM ltrSym) ]
    --buildValidM (Node _ ltrSym) = cmbnFast (++) "" ltrSym
    buildValidM _ = Error (ErrSymTree "instance Gen String" "buildValidM _")
 
instance Gen Char where
    buildValidDflt = ' '
    buildValidM (Node (Terminal ch) _) = Contains ch
    buildValidM _ = Error (ErrSymTree "instance Gen Char" "buildValidM _")