Creating data structures from symbol trees

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
 
module Main where
 
import qualified Data.Char as Ch
import Builder (Builder(..), SymbolTree(..), Construction(..), ErrorKind(..), SimpleContainer(..), String', cmbnFast, cmbnNCmt, buildValidMChar')
import qualified Builder as Sym (Symbol(..))
 
main :: IO ()
main = 
    do
        print (buildValidM symTheTree :: (Construction String'))
        print (buildValidM symTheTree :: (Construction ConstDef))
 
symTheTree :: SymbolTree
symTheTree = 
    Node Sym.ConstDef [                        -- shall create a ConstDef
        Node Sym.ConstName [                     -- shall create a String
            Node (Sym.Terminal 'n') [],            -- shall create a Char
            Node (Sym.Terminal 'M') [],            -- shall create a Char
            Node (Sym.Terminal 'y') [],            -- shall create a Char
            Node (Sym.Terminal 'C') [],            -- shall create a Char
            Node (Sym.Terminal 'o') [],            -- shall create a Char
            Node (Sym.Terminal 'n') [],            -- shall create a Char
            Node (Sym.Terminal 's') [],            -- shall create a Char
            Node (Sym.Terminal 't') []             -- shall create a Char
        ], 
        Node Sym.ConstExpression [                -- shall create an Integer
            Node Sym.Div [                          -- shall create an Integer
                Node Sym.Mul [                        -- shall create an Integer
                    Node Sym.Add [                      -- shall create an Integer
                        Node Sym.Number [                 -- shall create an Integer (and/or String)
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],     -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],     -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],     -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '1') []]],    -- shall create a Char
                        Node Sym.Number [                 -- shall create an Integer (and/or String)
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],     -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],     -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '1') []]]],   -- shall create a Char
                    Node Sym.Sub [                      -- shall create an Integer
                        Node Sym.Number [                 -- shall create an Integer (and/or String)
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],   -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []],   -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '1') []]],  -- shall create a Char
                        Node Sym.Number [               -- shall create an Integer (and/or String)
                            Node Sym.DecDigit [Node (Sym.Terminal '1') []],   -- shall create a Char
                            Node Sym.DecDigit [Node (Sym.Terminal '3') []]]]],-- shall create a Char
                Node Sym.Number [                       -- shall create an Integer (and/or String)
                    Node Sym.DecDigit [Node (Sym.Terminal '7') []]]]]]        -- shall create a Char
 
data ConstDef = ConstDef { rsConstName :: String, rnConstValue :: Integer }
    deriving Show
 
instance Builder ConstDef where
    buildValidDflt = ConstDef "" 0
    buildValidM (Node Sym.ConstDef (trSymConstName:trSymConstExpression:[])) = 
        do
            sConstName <- buildValidM trSymConstName
            nConstValue <- buildValidM trSymConstExpression
            return (ConstDef sConstName nConstValue)
    buildValidM (Node Sym.ConstDef _) = Error (ErrSymTree "instance Builder ConstDef" "buildValidM (Node Sym.ConstDef _)")
    buildValidM _ = Error (ErrSymTree "instance Builder ConstDef" "buildValidM _")
 
instance Builder Integer where
    buildValidDflt = 0
    buildValidM (Node Sym.ConstExpression (trSym:[])) = cnstInt "ConstExpression" $ buildValidM trSym
    buildValidM (Node Sym.ConstExpression _) = Error (ErrSymTree "instance Builder Integer" "buildValidM (Node Sym.ConstExpression _)")
    buildValidM (Node Sym.Number ltrSym) = cnstInt "Number" $ cmbnFast (\nA chB -> (10 * nA) + (toInteger ((Ch.ord chB) - 48))) 0 ltrSym
    buildValidM (Node Sym.Add ltrSym) = cnstInt "Add" $ cmbnFast (+) 0 ltrSym
    buildValidM (Node Sym.Sub ltrSym) = cnstInt "Sub" $ cmbnNCmt (-) 0 ltrSym
    buildValidM (Node Sym.Mul ltrSym) = cnstInt "Mul" $ cmbnFast (*) 1 ltrSym
    buildValidM (Node Sym.Div ltrSym) = cnstInt "Div" $ cmbnNCmt (div) 1 ltrSym
    buildValidM _ = Error (ErrSymTree "instance Builder Integer" "buildValidM _")
 
cnstInt :: String -> (Construction Integer) -> (Construction Integer)
cnstInt sCase g = constraint (\n -> (n >= 0) && (n <= 4294967295)) sCase "between 0 and 2^32-1" g
 
instance Builder String where
    buildValidDflt = ""
    buildValidM (Node Sym.ConstName ltrSym) = cnstConstName $ cmbnNCmt (\(Simply chA) sB -> chA : sB) [] ltrSym
    buildValidM _ = Error (ErrSymTree "instance Builder String" "buildValidM _")
 
cnstConstName :: (Construction String) -> (Construction String)
cnstConstName g = constraint (\s -> (length s) >= 0) "ConstName" "at least one character" g
 
instance Builder Char where
    buildValidDflt = ' '
    buildValidM (Node Sym.DecDigit (trSym:[])) = constraint (\ch -> (ch >= '0') && (ch <= '9')) "DecDigit" "between 0 and 9" $ buildValidMChar' trSym
    buildValidM (Node Sym.DecDigit _) = Error (ErrSymTree "instance Builder Char" "buildValidM (Node DecDigit _)")
    buildValidM _ = Error (ErrSymTree "instance Builder Char" "buildValidM _")

{-|
Description : to create data structures from symbol trees.
Copyright   : (c) Jörg K.-H. W. Brüggmann, 2021
License     : CC0 1.0 Universal
Maintainer  : - none -
Stability   : experimental
Portability : POSIX
 
* supports creation of any data structures from symbol trees which type is defined in here:
 
* example
 
    @
    instance Builder 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 Builder Integer" "buildValidM _")
 
    cnstInt :: String -> (Construction Integer) -> (Construction Integer)
    cnstInt sCase g = constraint (<= 4294967295) sCase "smaller than 2^32-1" g
 
    instance Builder String where
        buildValidDflt = ""
        buildValidM (Node Number ltrSym) = Contains [ch | (Contains ch) <- (map buildValidM ltrSym) ]
        buildValidM _ = Error (ErrSymTree "instance Builder String" "buildValidM _")
 
    instance Builder Char where
        buildValidDflt = ' '
        buildValidM (Node (Terminal ch) _) = Contains ch
        buildValidM _ = Error (ErrSymTree "instance Builder Char" "buildValidM _")
    @
-}
 
{-# LANGUAGE FlexibleInstances #-}
 
module Builder (
    -- * Classes
    Builder(..), 
    -- * Types
    SymbolTree(..), 
    Symbol(..), 
    Construction(..), 
    ErrorKind(..), 
    SimpleContainer(..), 
    String', 
    Char', 
    -- * Functions
    cmbnNCmt, 
    cmbnFast, 
    buildValidMChar'
    ) where
 
import qualified Control.Monad as M (liftM, ap)
import qualified Data.Foldable as Fld (foldlM, foldrM)
 
--------------------------------------------------------------------------------
--  Basic types
 
data Symbol = ConstDef | ConstName | ConstExpression | Add | Sub | Mul | Div | Number | DecDigit | Terminal Char
    deriving Show
 
data SymbolTree = Node Symbol [SymbolTree]
    deriving Show
 
data ErrorKind = 
      ErrSymTree { rsInstance :: String, rsPattern :: String }
    | Constraint { rsCase :: String, rsConstraint :: String }
    deriving Show
 
--------------------------------------------------------------------------------
--  Monadic type
 
data Construction model = Contains model | Error ErrorKind
    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
 
--------------------------------------------------------------------------------
--  Type class 'Builder'
 
class Builder 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)
 
--------------------------------------------------------------------------------
--  'Builder' instance for String' and Char'
 
newtype SimpleContainer a = Simply { rSimply :: a }
    deriving Show
 
fromSimple :: (Construction (SimpleContainer a)) -> (Construction a)
fromSimple (Contains (Simply x)) = Contains x
fromSimple (Error x) = Error x
 
type String' = SimpleContainer String
 
instance Builder (SimpleContainer String) where
    buildValidDflt = (Simply "")
    buildValidM (Node (Terminal ch) _) = Contains (Simply [ch])
    buildValidM (Node _ ltrSym) = (cmbnNCmt (liftSimply (++)) (Simply "") ltrSym)
 
liftSimply :: (a -> a -> a) -> (SimpleContainer a) -> (SimpleContainer a) -> (SimpleContainer a)
liftSimply f (Simply xA) (Simply xB) = Simply (f xA xB)
 
type Char' = SimpleContainer Char
 
instance Builder (SimpleContainer Char) where
    buildValidDflt = (Simply ' ')
    buildValidM (Node (Terminal ch) _) = Contains (Simply ch)
    buildValidM _ = Error (ErrSymTree "instance Builder Char'" "buildValidM _")
 
buildValidMChar' :: SymbolTree -> (Construction Char)
buildValidMChar' trSym = fromSimple (buildValidM trSym)
 
--------------------------------------------------------------------------------
--  Helper functions for type class 'Builder'
 
fLOpFromSymTree :: (Builder g, Builder a) => (g -> a -> g) -> g -> SymbolTree -> Construction g
fLOpFromSymTree fOp nA trSymB = 
    do
        chB <- buildValidM trSymB
        return (fOp nA chB)
 
fROpFromSymTree :: (Builder g, Builder a) => (a -> g -> g) -> SymbolTree -> g -> Construction g
fROpFromSymTree fOp trSymA nB = 
    do
        chA <- buildValidM trSymA
        return (fOp chA nB)
 
cmbnNCmt :: (Builder g, Builder a) => (a -> g -> g) -> g -> [SymbolTree] -> Construction g
cmbnNCmt fOp identity ltrSym = Fld.foldrM (fROpFromSymTree fOp) identity ltrSym
 
cmbnFast :: (Builder g, Builder a) => (g -> a -> g) -> g -> [SymbolTree] -> Construction g
cmbnFast fOp identity ltrSym = Fld.foldlM (fLOpFromSymTree fOp) identity ltrSym

Contains (Simply {rSimply = "nMyConst3331331331137"})
Contains (ConstDef {rsConstName = "nMyConst", rnConstValue = 166359})