====== Creating data structures from symbol trees ======
* example
* data structures for
* symbol tree
* with Terminal Chars as leafs
* container Construction as monadic class and instances
* error handling
* types for standard Construction instances
* ''String' ''
* in order to have standard build of constructions
* easy combination methods for childs of symbol trees
* ''cmbnFast''
* for faster execution, using ''foldlM''
* ''cmbnNCmt''
* for compatibility to non commutative operations like subtraction and devision, using ''foldrM''
* using GHC Extension ''[[codesnippets:flexibleinstances|FlexibleInstances]]''
* using GHC option ''[[codesnippets:fnowarnorphans|-fno-warn-orphans]]''
* code, module Main:
{-# 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 _")
* code, module Builder:
{-|
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
* compiles, error and warning free, with compiler: GHC 8.10.4, using -Wall
* executes, with output:
Contains (Simply {rSimply = "nMyConst3331331331137"})
Contains (ConstDef {rsConstName = "nMyConst", rnConstValue = 166359})
===== ✎ =====
~~DISCUSSION~~