lcc/Hcompta/LCC/Load.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Main where
   4
   5 import Control.Monad (Monad(..), forM_, (=<<))
   6 import Data.Eq (Eq)
   7 import Data.Typeable (Typeable)
   8 import Data.Either (Either(..))
   9 import Data.Function (($))
  10 import Data.Functor ((<$>))
  11 import Data.List.NonEmpty (NonEmpty)
  12 import System.IO (IO, stdout, stderr, print)
  13 import Text.Show (Show(..))
  14 import qualified Data.Strict as S
  15 import qualified System.Environment as Env
  16
  17 import qualified Language.Symantic.Document as Doc
  18 import qualified Language.Symantic as Sym
  19
  20 import qualified Hcompta.LCC.Sym as LCC.Sym
  21 import Hcompta.LCC.Posting (SourcePos)
  22 import Hcompta.LCC.Read
  23 import Hcompta.LCC.Write
  24 import Hcompta.LCC.Compta
  25 import Hcompta.LCC.Source
  26 import Hcompta.LCC.Sym.Compta ()
  27
  28 import Prelude (error)
  29
  30 type SS  = LCC.Sym.SS'
  31
  32 main :: IO ()
  33 main = do
  34         args <- Env.getArgs
  35         forM_ args $ \arg ->
  36                 readCompta @LCC.Sym.SRC @SS consTransactions arg >>= \case
  37                  Left (Error_Read_Syntax err) ->
  38                         showParseError err >>=
  39                         (`Doc.ansiIO` stderr)
  40                  Left (Error_Read_Semantic err) -> error $ show err
  41                  Right (r, warns) -> do
  42                         print warns
  43                         -- print r
  44                         (`Doc.ansiIO` stdout) $
  45                                 write (context_write, r)
  46
  47 printError :: Show err => Either err a -> IO a
  48 printError (Left err) = error $ show err
  49 printError (Right a)  = return a
  50
  51 printErrorS :: Show err => S.Either err a -> IO a
  52 printErrorS (S.Left err) = error $ show err
  53 printErrorS (S.Right a)  = return a
  54
  55 {-
  56 parseTe ::
  57  forall ss src.
  58  Inj_Modules src ss =>
  59  Gram_Term src ss (P.ParsecT P.Dec Text (SS.StateT (Sym.Imports, Modules src ss) Identity)) =>
  60  Text ->
  61  Either (P.ParseError Char P.Dec) (AST_Term src ss)
  62 parseTe inp =
  63         let mods::Modules src ss =
  64                 either (error . show) id $
  65                 Sym.deleteDefTermInfix ([] `Mod` "$") `fmap`
  66                 inj_Modules in
  67         let imps = importModulesAs [] mods in
  68         fmap reduceTeApp $
  69         runIdentity $
  70         MC.evalStateStrict (imps, mods) $
  71         P.runParserT g "" inp
  72         where
  73         g = unCF $ g_term <* eoi
  74
  75 readTe ::
  76  forall src ss.
  77  ( Gram_Term src ss (P.ParsecT P.Dec Text (SS.StateT (Sym.Imports, Modules src ss) Identity))
  78  , Syms ss Eval
  79  , Syms ss View
  80  , Syms ss (BetaT View)
  81  , Inj_Modules src ss
  82  , Eq src
  83  , Show src
  84  , Inj_Source (TypeVT src) src
  85  , Inj_Source (TypeT src '[]) src
  86  , Inj_Source (KindK src) src
  87  , Inj_Source (AST_Type src) src
  88  , Inj_Name2Type ss
  89  ) =>
  90  AST_Term src ss ->
  91  Either (Error_Term src) (TermVT src ss '[])
  92 readTe ast =
  93         let tys = inj_Name2Type (Proxy @ss) in
  94         Sym.readTerm tys CtxTyZ ast
  95
  96 evalTe ::
  97  Source src =>
  98  Syms ss View =>
  99  Syms ss Eval =>
 100  Syms ss (BetaT View) =>
 101  TermVT src ss '[] ->
 102  IO ()
 103 evalTe (TermVT (Term q t (TeSym te))) = do
 104         putStrLn $ "Type = " <> show (q #> t)
 105         case proveConstraint q of
 106          Nothing -> putStrLn $ "Cannot prove Constraint: " <> show q
 107          Just Dict -> do
 108                 Text.putStrLn $ "View = " <> view (betaT $ te CtxTeZ)
 109                 case proveConstraint $ Sym.tyShow t of
 110                  Nothing -> putStrLn $ "No Show instance for type: " <> show t
 111                  Just Dict -> putStrLn $ "Eval = " <> show (eval $ te CtxTeZ)
 112
 113 -- dbg :: Show a => String -> a -> a
 114 -- dbg msg x = trace (msg ++ " = " ++ show x) x
 115 -}