lcc/Hcompta/LCC/Sym/FileSystem.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for the file system.
   4 module Hcompta.LCC.Sym.FileSystem where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Eq (Eq)
   8 import Data.Foldable (concat)
   9 import Data.Function (($), (.))
  10 import Data.Functor (Functor(..), (<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Type.Equality ((:~:)(Refl))
  13 import System.IO (FilePath)
  14 import Text.Show (Show(..))
  15 import qualified Data.Text as Text
  16 import qualified Prelude ()
  17
  18 import Language.Symantic.Grammar
  19 import Language.Symantic
  20
  21 import Hcompta.LCC.Journal (PathFile(..))
  22
  23 -- * Class 'Sym_PathFile'
  24 type instance Sym PathFile = Sym_PathFile
  25 class Sym_PathFile term where
  26         pathfile :: PathFile -> term PathFile
  27         default pathfile :: Sym_PathFile (UnT term) => Trans term => PathFile -> term PathFile
  28         pathfile = trans . pathfile
  29
  30 instance Sym_PathFile Eval where
  31         pathfile = Eval
  32 instance Sym_PathFile View where
  33         pathfile a = View $ \_p _v -> Text.pack (show a)
  34 instance (Sym_PathFile r1, Sym_PathFile r2) => Sym_PathFile (Dup r1 r2) where
  35         pathfile x = pathfile x `Dup` pathfile x
  36 instance (Sym_PathFile term, Sym_Lambda term) => Sym_PathFile (BetaT term)
  37
  38 instance ClassInstancesFor PathFile where
  39         proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
  40          | Just HRefl <- proj_ConstKiTy @(K PathFile) @PathFile c
  41          = case () of
  42                  _ | Just Refl <- proj_Const @Eq q   -> Just Dict
  43                    | Just Refl <- proj_Const @Show q -> Just Dict
  44                  _ -> Nothing
  45         proveConstraintFor _c _q = Nothing
  46 instance TypeInstancesFor PathFile
  47
  48 instance -- Gram_Term_AtomsFor
  49  ( Gram_Rule g
  50  , Gram_Alt g
  51  , Gram_Comment g
  52  , Gram_Source src g
  53  , SymInj ss PathFile
  54  ) => Gram_Term_AtomsFor src ss g PathFile where
  55         g_term_atomsFor =
  56          [ rule "tePathFile" $
  57                 lexeme $ source $
  58                 (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ tePathFile a)
  59                  <$> g_pathfile
  60          ]
  61                 where
  62                 g_pathfile :: CF g PathFile
  63                 g_pathfile =
  64                         fmap PathFile $
  65                         (:)
  66                          <$> char '.'
  67                          <*> (concat <$> some ((:) <$> char '/' <*> g_pathfile_section))
  68                 g_pathfile_section :: CF g FilePath
  69                 g_pathfile_section = some (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
  70 instance (Source src, SymInj ss PathFile) => ModuleFor src ss PathFile where
  71         moduleFor = ["PathFile"] `moduleWhere`
  72          [
  73          ]
  74
  75 tyPathFile :: Source src => LenInj vs => Type src vs PathFile
  76 tyPathFile = tyConst @(K PathFile) @PathFile
  77
  78 tePathFile :: Source src => SymInj ss PathFile => PathFile -> Term src ss ts '[] (() #> PathFile)
  79 tePathFile a = Term noConstraint tyPathFile $ teSym @PathFile $ pathfile a