{-# LANGUAGE TemplateHaskell #-}
module Language.Drasil.Chunk.CodeBase where
import Control.Lens ((^.), view, makeLenses, Lens')
import Language.Drasil
import Database.Drasil (ChunkDB, symbResolve)
import Language.Drasil.Code.Expr (CodeExpr)
import Language.Drasil.Code.Expr.Extract (eDep, eDep')
import Utils.Drasil (toPlainName)
import Data.List (nub)
class CodeIdea c where
codeName :: c -> String
codeChunk :: c -> CodeChunk
class CodeIdea c => DefiningCodeExpr c where
codeExpr :: Lens' c CodeExpr
programName :: CommonIdea c => c -> String
programName :: c -> String
programName = String -> String
toPlainName (String -> String) -> (c -> String) -> c -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> String
forall c. CommonIdea c => c -> String
abrv
funcPrefix :: String
funcPrefix :: String
funcPrefix = "func_"
data VarOrFunc = Var | Func
data CodeChunk = CodeC { CodeChunk -> QuantityDict
_qc :: QuantityDict
, CodeChunk -> VarOrFunc
kind :: VarOrFunc
}
makeLenses ''CodeChunk
instance HasUID CodeChunk where uid :: (UID -> f UID) -> CodeChunk -> f CodeChunk
uid = (QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk
Lens' CodeChunk QuantityDict
qc ((QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk)
-> ((UID -> f UID) -> QuantityDict -> f QuantityDict)
-> (UID -> f UID)
-> CodeChunk
-> f CodeChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UID -> f UID) -> QuantityDict -> f QuantityDict
forall c. HasUID c => Lens' c UID
uid
instance NamedIdea CodeChunk where term :: (NP -> f NP) -> CodeChunk -> f CodeChunk
term = (QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk
Lens' CodeChunk QuantityDict
qc ((QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk)
-> ((NP -> f NP) -> QuantityDict -> f QuantityDict)
-> (NP -> f NP)
-> CodeChunk
-> f CodeChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP -> f NP) -> QuantityDict -> f QuantityDict
forall c. NamedIdea c => Lens' c NP
term
instance Idea CodeChunk where getA :: CodeChunk -> Maybe String
getA = QuantityDict -> Maybe String
forall c. Idea c => c -> Maybe String
getA (QuantityDict -> Maybe String)
-> (CodeChunk -> QuantityDict) -> CodeChunk -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting QuantityDict CodeChunk QuantityDict
-> CodeChunk -> QuantityDict
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting QuantityDict CodeChunk QuantityDict
Lens' CodeChunk QuantityDict
qc
instance HasSpace CodeChunk where typ :: (Space -> f Space) -> CodeChunk -> f CodeChunk
typ = (QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk
Lens' CodeChunk QuantityDict
qc ((QuantityDict -> f QuantityDict) -> CodeChunk -> f CodeChunk)
-> ((Space -> f Space) -> QuantityDict -> f QuantityDict)
-> (Space -> f Space)
-> CodeChunk
-> f CodeChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Space -> f Space) -> QuantityDict -> f QuantityDict
forall c. HasSpace c => Lens' c Space
typ
instance HasSymbol CodeChunk where symbol :: CodeChunk -> Stage -> Symbol
symbol = QuantityDict -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol (QuantityDict -> Stage -> Symbol)
-> (CodeChunk -> QuantityDict) -> CodeChunk -> Stage -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting QuantityDict CodeChunk QuantityDict
-> CodeChunk -> QuantityDict
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting QuantityDict CodeChunk QuantityDict
Lens' CodeChunk QuantityDict
qc
instance Quantity CodeChunk
instance Eq CodeChunk where c1 :: CodeChunk
c1 == :: CodeChunk -> CodeChunk -> Bool
== c2 :: CodeChunk
c2 = (CodeChunk
c1 CodeChunk -> Getting UID CodeChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeChunk UID
forall c. HasUID c => Lens' c UID
uid) UID -> UID -> Bool
forall a. Eq a => a -> a -> Bool
== (CodeChunk
c2 CodeChunk -> Getting UID CodeChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeChunk UID
forall c. HasUID c => Lens' c UID
uid)
instance MayHaveUnit CodeChunk where getUnit :: CodeChunk -> Maybe UnitDefn
getUnit = QuantityDict -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit (QuantityDict -> Maybe UnitDefn)
-> (CodeChunk -> QuantityDict) -> CodeChunk -> Maybe UnitDefn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting QuantityDict CodeChunk QuantityDict
-> CodeChunk -> QuantityDict
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting QuantityDict CodeChunk QuantityDict
Lens' CodeChunk QuantityDict
qc
data CodeVarChunk = CodeVC {CodeVarChunk -> CodeChunk
_ccv :: CodeChunk,
CodeVarChunk -> Maybe CodeChunk
_obv :: Maybe CodeChunk}
makeLenses ''CodeVarChunk
instance HasUID CodeVarChunk where uid :: (UID -> f UID) -> CodeVarChunk -> f CodeVarChunk
uid = (CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk
Lens' CodeVarChunk CodeChunk
ccv ((CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk)
-> ((UID -> f UID) -> CodeChunk -> f CodeChunk)
-> (UID -> f UID)
-> CodeVarChunk
-> f CodeVarChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UID -> f UID) -> CodeChunk -> f CodeChunk
forall c. HasUID c => Lens' c UID
uid
instance NamedIdea CodeVarChunk where term :: (NP -> f NP) -> CodeVarChunk -> f CodeVarChunk
term = (CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk
Lens' CodeVarChunk CodeChunk
ccv ((CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk)
-> ((NP -> f NP) -> CodeChunk -> f CodeChunk)
-> (NP -> f NP)
-> CodeVarChunk
-> f CodeVarChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP -> f NP) -> CodeChunk -> f CodeChunk
forall c. NamedIdea c => Lens' c NP
term
instance Idea CodeVarChunk where getA :: CodeVarChunk -> Maybe String
getA = CodeChunk -> Maybe String
forall c. Idea c => c -> Maybe String
getA (CodeChunk -> Maybe String)
-> (CodeVarChunk -> CodeChunk) -> CodeVarChunk -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeVarChunk CodeChunk
-> CodeVarChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeVarChunk CodeChunk
Lens' CodeVarChunk CodeChunk
ccv
instance HasSpace CodeVarChunk where typ :: (Space -> f Space) -> CodeVarChunk -> f CodeVarChunk
typ = (CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk
Lens' CodeVarChunk CodeChunk
ccv ((CodeChunk -> f CodeChunk) -> CodeVarChunk -> f CodeVarChunk)
-> ((Space -> f Space) -> CodeChunk -> f CodeChunk)
-> (Space -> f Space)
-> CodeVarChunk
-> f CodeVarChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Space -> f Space) -> CodeChunk -> f CodeChunk
forall c. HasSpace c => Lens' c Space
typ
instance HasSymbol CodeVarChunk where symbol :: CodeVarChunk -> Stage -> Symbol
symbol = CodeChunk -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol (CodeChunk -> Stage -> Symbol)
-> (CodeVarChunk -> CodeChunk) -> CodeVarChunk -> Stage -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeVarChunk CodeChunk
-> CodeVarChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeVarChunk CodeChunk
Lens' CodeVarChunk CodeChunk
ccv
instance Quantity CodeVarChunk
instance Eq CodeVarChunk where c1 :: CodeVarChunk
c1 == :: CodeVarChunk -> CodeVarChunk -> Bool
== c2 :: CodeVarChunk
c2 = (CodeVarChunk
c1 CodeVarChunk -> Getting UID CodeVarChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeVarChunk UID
forall c. HasUID c => Lens' c UID
uid) UID -> UID -> Bool
forall a. Eq a => a -> a -> Bool
== (CodeVarChunk
c2 CodeVarChunk -> Getting UID CodeVarChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeVarChunk UID
forall c. HasUID c => Lens' c UID
uid)
instance MayHaveUnit CodeVarChunk where getUnit :: CodeVarChunk -> Maybe UnitDefn
getUnit = CodeChunk -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit (CodeChunk -> Maybe UnitDefn)
-> (CodeVarChunk -> CodeChunk) -> CodeVarChunk -> Maybe UnitDefn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeVarChunk CodeChunk
-> CodeVarChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeVarChunk CodeChunk
Lens' CodeVarChunk CodeChunk
ccv
newtype CodeFuncChunk = CodeFC {CodeFuncChunk -> CodeChunk
_ccf :: CodeChunk}
makeLenses ''CodeFuncChunk
instance HasUID CodeFuncChunk where uid :: (UID -> f UID) -> CodeFuncChunk -> f CodeFuncChunk
uid = (CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk
Iso' CodeFuncChunk CodeChunk
ccf ((CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk)
-> ((UID -> f UID) -> CodeChunk -> f CodeChunk)
-> (UID -> f UID)
-> CodeFuncChunk
-> f CodeFuncChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UID -> f UID) -> CodeChunk -> f CodeChunk
forall c. HasUID c => Lens' c UID
uid
instance NamedIdea CodeFuncChunk where term :: (NP -> f NP) -> CodeFuncChunk -> f CodeFuncChunk
term = (CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk
Iso' CodeFuncChunk CodeChunk
ccf ((CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk)
-> ((NP -> f NP) -> CodeChunk -> f CodeChunk)
-> (NP -> f NP)
-> CodeFuncChunk
-> f CodeFuncChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP -> f NP) -> CodeChunk -> f CodeChunk
forall c. NamedIdea c => Lens' c NP
term
instance Idea CodeFuncChunk where getA :: CodeFuncChunk -> Maybe String
getA = CodeChunk -> Maybe String
forall c. Idea c => c -> Maybe String
getA (CodeChunk -> Maybe String)
-> (CodeFuncChunk -> CodeChunk) -> CodeFuncChunk -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeFuncChunk CodeChunk
-> CodeFuncChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeFuncChunk CodeChunk
Iso' CodeFuncChunk CodeChunk
ccf
instance HasSpace CodeFuncChunk where typ :: (Space -> f Space) -> CodeFuncChunk -> f CodeFuncChunk
typ = (CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk
Iso' CodeFuncChunk CodeChunk
ccf ((CodeChunk -> f CodeChunk) -> CodeFuncChunk -> f CodeFuncChunk)
-> ((Space -> f Space) -> CodeChunk -> f CodeChunk)
-> (Space -> f Space)
-> CodeFuncChunk
-> f CodeFuncChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Space -> f Space) -> CodeChunk -> f CodeChunk
forall c. HasSpace c => Lens' c Space
typ
instance HasSymbol CodeFuncChunk where symbol :: CodeFuncChunk -> Stage -> Symbol
symbol = CodeChunk -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol (CodeChunk -> Stage -> Symbol)
-> (CodeFuncChunk -> CodeChunk) -> CodeFuncChunk -> Stage -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeFuncChunk CodeChunk
-> CodeFuncChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeFuncChunk CodeChunk
Iso' CodeFuncChunk CodeChunk
ccf
instance Quantity CodeFuncChunk
instance Callable CodeFuncChunk
instance Eq CodeFuncChunk where c1 :: CodeFuncChunk
c1 == :: CodeFuncChunk -> CodeFuncChunk -> Bool
== c2 :: CodeFuncChunk
c2 = (CodeFuncChunk
c1 CodeFuncChunk -> Getting UID CodeFuncChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeFuncChunk UID
forall c. HasUID c => Lens' c UID
uid) UID -> UID -> Bool
forall a. Eq a => a -> a -> Bool
== (CodeFuncChunk
c2 CodeFuncChunk -> Getting UID CodeFuncChunk UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID CodeFuncChunk UID
forall c. HasUID c => Lens' c UID
uid)
instance MayHaveUnit CodeFuncChunk where getUnit :: CodeFuncChunk -> Maybe UnitDefn
getUnit = CodeChunk -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit (CodeChunk -> Maybe UnitDefn)
-> (CodeFuncChunk -> CodeChunk) -> CodeFuncChunk -> Maybe UnitDefn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting CodeChunk CodeFuncChunk CodeChunk
-> CodeFuncChunk -> CodeChunk
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CodeChunk CodeFuncChunk CodeChunk
Iso' CodeFuncChunk CodeChunk
ccf
quantvar :: (Quantity c, MayHaveUnit c) => c -> CodeVarChunk
quantvar :: c -> CodeVarChunk
quantvar c :: c
c = CodeChunk -> Maybe CodeChunk -> CodeVarChunk
CodeVC (QuantityDict -> VarOrFunc -> CodeChunk
CodeC (c -> QuantityDict
forall q. (Quantity q, MayHaveUnit q) => q -> QuantityDict
qw c
c) VarOrFunc
Var) Maybe CodeChunk
forall a. Maybe a
Nothing
quantfunc :: (Quantity c, MayHaveUnit c) => c -> CodeFuncChunk
quantfunc :: c -> CodeFuncChunk
quantfunc c :: c
c = CodeChunk -> CodeFuncChunk
CodeFC (CodeChunk -> CodeFuncChunk) -> CodeChunk -> CodeFuncChunk
forall a b. (a -> b) -> a -> b
$ QuantityDict -> VarOrFunc -> CodeChunk
CodeC (c -> QuantityDict
forall q. (Quantity q, MayHaveUnit q) => q -> QuantityDict
qw c
c) VarOrFunc
Func
codevars :: CodeExpr -> ChunkDB -> [CodeVarChunk]
codevars :: CodeExpr -> ChunkDB -> [CodeVarChunk]
codevars e :: CodeExpr
e m :: ChunkDB
m = (UID -> CodeVarChunk) -> [UID] -> [CodeVarChunk]
forall a b. (a -> b) -> [a] -> [b]
map (ChunkDB -> UID -> CodeVarChunk
varResolve ChunkDB
m) ([UID] -> [CodeVarChunk]) -> [UID] -> [CodeVarChunk]
forall a b. (a -> b) -> a -> b
$ CodeExpr -> [UID]
eDep CodeExpr
e
codevars' :: CodeExpr -> ChunkDB -> [CodeVarChunk]
codevars' :: CodeExpr -> ChunkDB -> [CodeVarChunk]
codevars' e :: CodeExpr
e m :: ChunkDB
m = (UID -> CodeVarChunk) -> [UID] -> [CodeVarChunk]
forall a b. (a -> b) -> [a] -> [b]
map (ChunkDB -> UID -> CodeVarChunk
varResolve ChunkDB
m) ([UID] -> [CodeVarChunk]) -> [UID] -> [CodeVarChunk]
forall a b. (a -> b) -> a -> b
$ [UID] -> [UID]
forall a. Eq a => [a] -> [a]
nub ([UID] -> [UID]) -> [UID] -> [UID]
forall a b. (a -> b) -> a -> b
$ CodeExpr -> [UID]
eDep' CodeExpr
e
varResolve :: ChunkDB -> UID -> CodeVarChunk
varResolve :: ChunkDB -> UID -> CodeVarChunk
varResolve m :: ChunkDB
m x :: UID
x = QuantityDict -> CodeVarChunk
forall c. (Quantity c, MayHaveUnit c) => c -> CodeVarChunk
quantvar (QuantityDict -> CodeVarChunk) -> QuantityDict -> CodeVarChunk
forall a b. (a -> b) -> a -> b
$ ChunkDB -> UID -> QuantityDict
symbResolve ChunkDB
m UID
x
funcResolve :: ChunkDB -> UID -> CodeFuncChunk
funcResolve :: ChunkDB -> UID -> CodeFuncChunk
funcResolve m :: ChunkDB
m x :: UID
x = QuantityDict -> CodeFuncChunk
forall c. (Quantity c, MayHaveUnit c) => c -> CodeFuncChunk
quantfunc (QuantityDict -> CodeFuncChunk) -> QuantityDict -> CodeFuncChunk
forall a b. (a -> b) -> a -> b
$ ChunkDB -> UID -> QuantityDict
symbResolve ChunkDB
m UID
x
listToArray :: CodeVarChunk -> CodeVarChunk
listToArray :: CodeVarChunk -> CodeVarChunk
listToArray c :: CodeVarChunk
c = Space -> CodeVarChunk
newSpc (CodeVarChunk
c CodeVarChunk -> Getting Space CodeVarChunk Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space CodeVarChunk Space
forall c. HasSpace c => Lens' c Space
typ)
where newSpc :: Space -> CodeVarChunk
newSpc (Vect t :: Space
t) = CodeChunk -> Maybe CodeChunk -> CodeVarChunk
CodeVC (QuantityDict -> VarOrFunc -> CodeChunk
CodeC (String
-> NP
-> Maybe String
-> Space
-> Symbol
-> Maybe UnitDefn
-> QuantityDict
implVar' (UID -> String
forall a. Show a => a -> String
show (UID -> String) -> UID -> String
forall a b. (a -> b) -> a -> b
$ CodeVarChunk
c CodeVarChunk -> String -> UID
forall a. HasUID a => a -> String -> UID
+++ "_array")
(CodeVarChunk
c CodeVarChunk -> Getting NP CodeVarChunk NP -> NP
forall s a. s -> Getting a s a -> a
^. Getting NP CodeVarChunk NP
forall c. NamedIdea c => Lens' c NP
term) (CodeVarChunk -> Maybe String
forall c. Idea c => c -> Maybe String
getA CodeVarChunk
c) (Space -> Space
Array Space
t) (CodeVarChunk -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol CodeVarChunk
c Stage
Implementation) (CodeVarChunk -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit CodeVarChunk
c))
VarOrFunc
Var) (CodeVarChunk
c CodeVarChunk
-> Getting (Maybe CodeChunk) CodeVarChunk (Maybe CodeChunk)
-> Maybe CodeChunk
forall s a. s -> Getting a s a -> a
^. Getting (Maybe CodeChunk) CodeVarChunk (Maybe CodeChunk)
Lens' CodeVarChunk (Maybe CodeChunk)
obv)
newSpc _ = CodeVarChunk
c