]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Eval.hs
Remove cli/
[comptalang.git] / lcc / Hcompta / LCC / Eval.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Main where
5
6 import Control.Applicative (Applicative(..))
7 import Control.Monad (Monad(..), forM)
8 import Data.Bool (Bool(..))
9 import Data.Char (Char)
10 import Data.Either (Either(..), either)
11 import Data.Eq (Eq)
12 import Data.Function (($), (.), id)
13 import Data.Functor (Functor(..), (<$>))
14 import Data.Functor.Identity (Identity(..))
15 import Data.Foldable (foldr1)
16 import Data.Maybe (Maybe(..), maybe)
17 import Data.Semigroup ((<>))
18 import Data.Text (Text)
19 import Prelude (error)
20 import System.IO (IO, putStrLn)
21 import Text.Show (Show(..))
22 import qualified Control.Monad.Classes.Run as MC
23 import qualified Control.Monad.Trans.State.Strict as SS
24 import qualified Data.Char as Char
25 import qualified Data.List as L
26 import qualified Data.Map.Strict as Map
27 import qualified Data.Text as T
28 import qualified Data.Text as Text
29 import qualified Data.Text.IO as Text
30 import qualified System.Environment as Env
31 import qualified System.IO as IO
32 import qualified Text.Megaparsec as P
33
34 import Language.Symantic as Sym
35 import qualified Language.Symantic.Document as D
36 import qualified Language.Symantic.Grammar as G
37 import qualified Language.Symantic.Lib as Sym
38
39 import qualified Hcompta.LCC.Sym as LCC.Sym
40 -- import qualified Hcompta.LCC as LCC
41 import Hcompta.LCC.Read ()
42
43 -- dbg :: Show a => String -> a -> a
44 -- dbg msg x = trace (msg ++ " = " ++ show x) x
45
46
47 main :: IO ()
48 main = do
49 args <- Env.getArgs
50 let modsTy = Sym.modulesTyInj @LCC.Sym.SS @LCC.Sym.SRC
51 let impsTy = Sym.importTypes @LCC.Sym.CS []
52 let modsTe :: Modules LCC.Sym.SRC LCC.Sym.SS =
53 either (error . show) id $
54 Sym.deleteDefTermInfix ([] `Mod` "$") `fmap`
55 modulesInj
56 let impsTe = [] `Sym.importModules` modsTe
57 (`D.ansiIO` IO.stderr) $ docModules impsTy modsTe
58 let arg = Text.unwords $ Text.pack <$> args
59 ast <- printError $ parseTe (impsTy, modsTy) (impsTe, modsTe) arg
60 {-
61 ast <- (foldr1 G.BinTree2 <$>) $ forM args $ \arg -> do
62 printError $ parseTe (impsTy, modsTy) (impsTe, modsTe) $ Text.pack arg
63 -}
64 te <- printError $ readTe ast
65 evalTe impsTy te
66 {-
67 forM_ args $ \arg -> do
68 ast <- printError $ parseTe (impsTy, modsTy) (impsTe, modsTe) $ Text.pack arg
69 te <- printError $ readTe ast
70 evalTe impsTy te
71 -}
72
73 printError :: Show err => Either err a -> IO a
74 printError (Left err) = error $ show err
75 printError (Right a) = return a
76
77
78 type G src ss =
79 P.ParsecT P.Dec Text
80 (SS.StateT (Imports NameTe, Modules src ss)
81 ((SS.StateT (Imports NameTy, ModulesTy src))
82 Identity))
83
84 parseTe ::
85 forall ss src.
86 Gram_Term src ss (G src ss) =>
87 (Imports NameTy, ModulesTy src) ->
88 (Imports NameTe, Modules src ss) ->
89 Text -> Either (P.ParseError Char P.Dec) (AST_Term src ss)
90 parseTe tys tes inp =
91 runIdentity $
92 MC.evalStateStrict tys $
93 MC.evalStateStrict tes $
94 P.runParserT g "" inp
95 where g = G.unCF $ Sym.g_term <* G.eoi
96
97 type ReadTe src ss =
98 ( Gram_Term src ss (G src ss)
99 , ImportTypes ss
100 , ModulesInj src ss
101 , ModulesTyInj ss
102 , SourceInj (TypeVT src) src
103 , SourceInj (KindK src) src
104 , SourceInj (AST_Type src) src
105 )
106
107 readTe ::
108 forall src ss.
109 ( Syms ss Eval
110 , Syms ss View
111 , Syms ss (BetaT View)
112 , ReadTe src ss
113 , Eq src
114 , Show src
115 ) =>
116 AST_Term src ss ->
117 Either (Error_Term src) (TermVT src ss '[])
118 readTe = Sym.readTerm CtxTyZ
119
120 evalTe ::
121 Source src =>
122 Syms ss View =>
123 Syms ss Eval =>
124 Syms ss (BetaT View) =>
125 Sym.Imports Sym.NameTy ->
126 TermVT src ss '[] ->
127 IO ()
128 evalTe imps (TermVT (Term q t (TeSym te))) = do
129 (`D.ansiIO` IO.stdout) $ "Type = " <> Sym.docType
130 Sym.config_Doc_Type
131 { config_Doc_Type_vars_numbering = False
132 , config_Doc_Type_imports = imps
133 } 0 (q #> t) <> D.eol
134 case proveConstraint q of
135 Nothing -> putStrLn $ "Cannot prove Constraint: " <> show q
136 Just Dict -> do
137 Text.putStrLn $ "View = " <> view (betaT $ te CtxTeZ)
138 case t of
139 TyApp _ io aTy | Just HRefl <- proj_ConstKiTy @_ @IO io -> do
140 a <- eval $ te CtxTeZ
141 case proveConstraint $ Sym.tyShow aTy of
142 Nothing -> putStrLn $ "No Show instance for type: " <> show aTy
143 Just Dict -> putStrLn $ "Eval = " <> show a
144 _ ->
145 let a = eval $ te CtxTeZ in
146 case proveConstraint $ Sym.tyShow t of
147 Nothing -> putStrLn $ "No Show instance for type: " <> show t
148 Just Dict -> putStrLn $ "Eval = " <> show a
149
150 {-
151 main :: IO ()
152 main = do
153 args <- Env.getArgs
154 forM_ args $ \arg ->
155 readCompta @LCC.Sym.SRC @SS arg >>= \case
156 Left (Error_Read_Syntax err) ->
157 showParseError err >>=
158 (`Doc.ansiIO` stderr)
159 Left (Error_Read_Semantic err) -> error $ show err
160 Right (r, warns) -> do
161 print warns
162 -- print r
163 (`Doc.ansiIO` stdout) $
164 d_compta context_write r
165
166 printError :: Show err => Either err a -> IO a
167 printError (Left err) = error $ show err
168 printError (Right a) = return a
169
170 printErrorS :: Show err => S.Either err a -> IO a
171 printErrorS (S.Left err) = error $ show err
172 printErrorS (S.Right a) = return a
173 -}
174
175 docModules ::
176 Source src =>
177 D.Doc_Text d =>
178 D.Doc_Color d =>
179 D.Doc_Decoration d =>
180 ReadTe src ss =>
181 Sym.Imports Sym.NameTy ->
182 Sym.Modules src ss -> d
183 docModules imps (Sym.Modules mods) =
184 Map.foldrWithKey
185 (\p m doc -> docModule imps p m <> doc)
186 D.empty
187 mods
188
189 docModule ::
190 forall src ss d.
191 Source src =>
192 D.Doc_Text d =>
193 D.Doc_Color d =>
194 D.Doc_Decoration d =>
195 ReadTe src ss =>
196 Sym.Imports Sym.NameTy ->
197 Sym.PathMod -> Sym.Module src ss -> d
198 docModule imps m Sym.ByFixity
199 { Sym.byPrefix
200 , Sym.byInfix
201 , Sym.byPostfix
202 } =
203 go docFixityInfix byInfix <>
204 go docFixityPrefix byPrefix <>
205 go docFixityPostfix byPostfix
206 where
207 go :: (fixy -> d) -> ModuleFixy src ss fixy -> d
208 go docFixy =
209 Map.foldrWithKey
210 (\n Sym.Tokenizer
211 { Sym.token_fixity
212 , Sym.token_term = t
213 } doc ->
214 docPathTe m n <>
215 docFixy token_fixity <>
216 D.space <> D.bold (D.yellower "::") <> D.space <>
217 docTokenTerm imps (t Sym.noSource) <>
218 D.eol <> doc)
219 D.empty
220
221 docTokenTerm ::
222 forall src ss d.
223 Source src =>
224 D.Doc_Text d =>
225 D.Doc_Color d =>
226 ReadTe src ss =>
227 Sym.Imports Sym.NameTy ->
228 Sym.Token_Term src ss -> d
229 docTokenTerm imps t =
230 case Sym.readTerm CtxTyZ (G.BinTree0 t) of
231 Left{} -> error "[BUG] docTokenTerm: readTerm failed"
232 Right (Sym.TermVT te) ->
233 Sym.docType Sym.config_Doc_Type
234 { config_Doc_Type_vars_numbering = False
235 , config_Doc_Type_imports = imps
236 } 0 $ Sym.typeOfTerm te
237
238 docFixityInfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Infix -> t
239 docFixityInfix = \case
240 Sym.Infix Nothing 5 -> D.empty
241 Sym.Infix a p ->
242 let docAssoc = \case
243 Sym.AssocL -> "l"
244 Sym.AssocR -> "r"
245 Sym.AssocB Sym.SideL -> "l"
246 Sym.AssocB Sym.SideR -> "r" in
247 D.magenta $ " infix" <> maybe D.empty docAssoc a <>
248 D.space <> D.bold (D.bluer (D.int p))
249 docFixityPrefix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
250 docFixityPrefix p = D.magenta $ " prefix " <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
251 docFixityPostfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
252 docFixityPostfix p = D.magenta $ " postfix " <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
253
254 docPathTe ::
255 D.Doc_Text d =>
256 D.Doc_Color d =>
257 Sym.PathMod -> Sym.NameTe -> d
258 docPathTe (ms::Sym.PathMod) (Sym.NameTe n) =
259 D.catH $
260 L.intersperse (D.charH '.') $
261 ((\(Sym.NameMod m) -> D.textH m) <$> ms) <>
262 [(if isOp n then id else D.yellower) $ D.text n]
263 where
264 isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
265