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.IO (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 NameTyOf PathFile where
  39         nameTyOf _c = ["FS"] `Mod` "PathFile"
  40 instance ClassInstancesFor PathFile where
  41         proveConstraintFor _ (TyConst _ _ q :$ c)
  42          | Just HRefl <- proj_ConstKiTy @(K PathFile) @PathFile c
  43          = case () of
  44                  _ | Just Refl <- proj_Const @Eq q   -> Just Dict
  45                    | Just Refl <- proj_Const @Show q -> Just Dict
  46                  _ -> Nothing
  47         proveConstraintFor _c _q = Nothing
  48 instance TypeInstancesFor PathFile
  49
  50 instance -- Gram_Term_AtomsFor
  51  ( Gram_Rule g
  52  , Gram_Alt g
  53  , Gram_Comment g
  54  , Gram_Source src g
  55  , SymInj ss PathFile
  56  ) => Gram_Term_AtomsFor src ss g PathFile where
  57         g_term_atomsFor =
  58          [ rule "tePathFile" $
  59                 lexeme $ source $
  60                 (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ tePathFile a)
  61                  <$> g_pathfile
  62          ]
  63                 where
  64                 g_pathfile :: CF g PathFile
  65                 g_pathfile =
  66                         fmap PathFile $
  67                         (:)
  68                          <$> char '.'
  69                          <*> (concat <$> some ((:) <$> char '/' <*> g_pathfile_section))
  70                 g_pathfile_section :: CF g FilePath
  71                 g_pathfile_section = some (choice $ char '.' : (unicat <$> [Unicat_Letter, Unicat_Number]))
  72 instance (Source src, SymInj ss PathFile) => ModuleFor src ss PathFile where
  73         moduleFor = ["FS", "PathFile"] `moduleWhere`
  74          [
  75          ]
  76
  77 tyPathFile :: Source src => LenInj vs => Type src vs PathFile
  78 tyPathFile = tyConst @(K PathFile) @PathFile
  79
  80 tePathFile :: Source src => SymInj ss PathFile => PathFile -> Term src ss ts '[] (() #> PathFile)
  81 tePathFile a = Term noConstraint tyPathFile $ teSym @PathFile $ pathfile a